PDA

View Full Version : Solved: How to repeat a procedure/code a number of times



Jamyhamy
07-31-2012, 10:31 AM
Hi,

I have some lengthy code that adds data to a column and then perfoms some calculations. I would like to repeat the same code to run a maximum of 15 times.

Example of the code is below. Running this code once populates column 4 of sheets "Version 1" and "Basesheet" assuming the criteria in the code below is met. I want to run the code from POINT B onwards a mximum of 14 times. Running it again should populate column 5 of the sheets and then 6, 7, 8, etc for each time it is run. But the columns will only populate incrementally if the criteria is met relating to the line:

"If Abs(pvalue) > Range("c9").Value Then"

But assuming the criteria is met everytime, I want it to stop runing after 15 times when column R is populated. So I want to do something like

"If Sheets("Results").Range("R14") = "" Then
' run code else don't run

Hope someone can advise best way to do this.

Thanks,

JamyHamy

------------------------------------

Sub A111A ()
Application.ScreenUpdating = False
Dim var1 As String
lastrow = Range("B15").End(xlDown).row
startrange = 14
Sheets("Results").Range("B3:R7").ClearContents
Sheets("Results").Range(Cells(14, 4), Cells(lastrow, 18)).Clear
Range("U4:X4").ClearContents 'old output
lastvar = Split(Range("R14").End(xlToLeft).Offset(0, 1).Address, "$")(1)


'XXXX POINT B RUN CODE FROM HERE ONLY A MAXIMUM 15 TIMES XXXX


CALL InitialCalculations

Sheets("BaseSheet").Select
Range("x1:x" & lastrow).Value = Range("V1:v" & lastrow).Value

Range("X1:X" & lastrow).Select
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("X1").Value = "Stat"

k = Sheets("BaseSheet").Range("S1").End(xlDown).row

For i = 2 To k 'assumes RawData begins with column 3
Sheets("BaseSheet").Select
var1 = Cells(i, 19).Value 'Range("AA2").Value
If Sheets("Results").Range(lastvar & "14") = "" Then
Sheets("RawData").Select
With Sheets("RawData").Rows("1:1")
Set rng = .Find(What:=var1, _
After:=Sheets("RawData").Range("a1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rng Is Nothing Then
Application.GoTo rng, True
Else
MsgBox "Nothing found"
End If
End With

y = ActiveCell.Column
Range(Cells(1, y), Cells(lastrow, y)).Copy
Sheets("Results").Select
Range("U14").PasteSpecial Paste:=xlPasteValues


pvalue = Range("W4").Value
If Abs(pvalue) > Range("c9").Value Then
H = Range("R14").End(xlToLeft).Offset(0, 1).Column
Sheets("Results").Range(Cells(14, H), Cells(lastrow, H)).Value = Sheets("Results").Range(Cells(14, 21), Cells(lastrow, 21)).Value
ExistRange = Range("B14").End(xlToRight).Column

Sheets("Results").Range(Cells(14, 4), Cells(lastrow, ExistRange)).Copy
Sheets("BaseSheet").Select
Range("d14").PasteSpecial Paste:=xlPasteValues
End If
End If
Next i
Call estimate_Results
Else: Exit Sub
End If
End Sub

CatDaddy
07-31-2012, 11:02 AM
wrap entire code in:
For i=1 to 15
'''
Next i

Jamyhamy
08-02-2012, 03:24 AM
Thanks, that seems to work.

BTW - is there any way I can improve/speed up this code/clean it up?

Thanks,

Jamyhamy

Bob Phillips
08-02-2012, 04:29 AM
See if this is any better

Sub A111A()
Dim shResults As Worksheet
Dim shRawData As Worksheet
Dim rng As Range
Dim var1 As String
Dim Lastrow As Long
Dim lastvar As Variant
Dim pValue As Variant
Dim Startrange As Long
Dim existrange As Long
Dim H As Long
Dim i As Long, k As Long, y As Long

Application.ScreenUpdating = False

Set shResults = Worksheets("Results")
Set shRawData = Worksheets("RawData")
Lastrow = Range("B15").End(xlDown).Row
Startrange = 14

shResults.Range("B3:R7").ClearContents
shResults.Range(Cells(14, 4), Cells(Lastrow, 18)).Clear
Range("U4:X4").ClearContents 'old output
lastvar = Split(Range("R14").End(xlToLeft).Offset(0, 1).Address, "$")(1)

'XXXX POINT B RUN CODE FROM HERE ONLY A MAXIMUM 15 TIMES XXXX

Call InitialCalculations

With Worksheets("BaseSheet")

.Range("x1:x" & Lastrow).Value = .Range("V1:v" & Lastrow).Value

.Range("X1:X" & Lastrow).Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
.Range("X1").Value = "Stat"

k = .Range("S1").End(xlDown).Row

For i = 2 To k 'assumes RawData begins with column 3

var1 = Cells(i, 19).Value 'Range("AA2").Value
If shResults.Range(lastvar & "14") = "" Then

Set rng = shRawData.Rows("1:1").Find(What:=var1, _
After:=shRawData.Range("a1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If rng Is Nothing Then

MsgBox "Nothing found for row " & i
Else

y = rng.Column
Range(Cells(1, y), Cells(Lastrow, y)).Copy
shResults.Range("U14").PasteSpecial Paste:=xlPasteValues

pValue = Range("W4").Value
If Abs(pValue) > shResults.Range("C9").Value Then

H = shResults.Range("R14").End(xlToLeft).Offset(0, 1).Column
shResults.Range(shResults.Cells(14, H), shResults.Cells(Lastrow, H)).Value = _
shResults.Range(shResults.Cells(14, 21), shResults.Cells(Lastrow, 21)).Value
existrange = shResults.Range("B14").End(xlToRight).Column

shResults.Range(shResults.Cells(14, 4), shResults.Cells(Lastrow, existrange)).Copy
.Range("D14").PasteSpecial Paste:=xlPasteValues
End If
End If
End If
Next i

Call estimate_Results
End With

Application.ScreenUpdating = True
End Sub

Jamyhamy
08-02-2012, 10:18 AM
Thanks very much XLD.

I can see by just looking at it that it seems a lot more efficient than what I came up with.

I'll integrate into my code. I'm also working on removing the need for one of the sheets ("BaseSheet") and trying to do it all on one of the sheet ("Results") so hopefully it will be a lot more efficent.

I post outcome once I have made all changes and tested it out.

Jamy Hamy

Jamyhamy
08-03-2012, 03:42 AM
Just a quick question,

Given I want to run this for a maximum 15 times but only if running the previous time delivers a change, if there is no change say at running the 5th time, I do not want to it run 6, 7 or 8 times as that is just a waste.

Anyone suggest what the best way to incorporate this would be? Basically I want to check whether running the whole code delivered a change. A change here is defined as a new column populated in shResults. If no new column is populated after running the entire code then I want to macro to end as running it any more times will not chnage the final result.

Bob Phillips
08-03-2012, 04:46 AM
Just set a boolean variable to true where that column is updated, and test that boolean in the loop setting the loop counter to 15.

Jamyhamy
08-28-2012, 07:54 AM
Thanks Xld.

Struggling a but with your Bolean approach so I have I've tried variations of the below instead but it is generating a "loop without Do" error message.


sub huhuh
Do
For i = 1 To 15
lastempty = Split(Range("R14").End(xlToLeft).Offset(0, 1).Address, "$")(1)
Loop While (Range(lastempty & "14") <> "")
'rest of main code here

next i
end sub


After each successive iteration of the code, the lastempty column should populate, if it is still blank then the procedure should terminate.

Any ideas?

Thanks.

Bob Phillips
08-28-2012, 08:33 AM
Complete aor-code, but this is the sort of thing that I meant

Sub huhuh()
Dim flg As Boolean

flg = False
For i = 1 To 15

Do
lastempty = Split(Range("R14").End(xlToLeft).Offset(0, 1).Address, "$")(1)
Loop While (Range(lastempty & "14") <> "")

'rest of main code here
flg = some condition is true 'eg Range("M5").Value > 0
If flg Then Exit For
Next i
End Sub

Jamyhamy
09-25-2012, 04:57 AM
Ok, I've managed to get it to work but not exactly how described but by using this:


For model = 1 To 12
lastempty = Split(Range("R14").End(xlToLeft).Offset(0, 1).Address, "$")(1)

'rest of code

flg = Range(lastempty & "14").Value
If flg = "" Then Exit For


Thanks for the help.

Jamyhamy
10-15-2012, 04:31 AM
Hi,

Based on the feedback to my post here is the final code I have come up with. Overall it works fine however it is falling down at the the section called ****DOES NOT WORK*******

i.e: it is not copying the columns data over into the sheet:

Sheets("X Variables").Range(Cells(1, y), Cells(Lastrow, y)).Copy
Sheets("Build-Linear").Range("U14").PasteSpecial Paste:=xlPasteValues

Any ideas why this is not working?

Thanks

JH


Sub Test_Alternative_code()
Dim lastcol, sortcol, columnnum As Integer
Dim lastvar, lastempty, outvariables As Variant
Dim Startrange, existrange, s As Long
Dim Lastrow As Long
Dim pvalue, critz As Variant
Dim direction As String
Dim i As Long, k As Long, h As Long, y As Long
Dim sortdirect
Dim rRef As Range, rCalc As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Application.DisplayStatusBar = False

Lastrow = Range("B14").End(xlDown).row
Startrange = 14
Sheets("Build-Linear").Range("C3:R4").ClearContents
Sheets("Build-Linear").Range(Cells(14, 4), Cells(Lastrow, 18)).Clear
Range("AA2:AP300").Clear
z = Sheets("X Variables").Cells(1, 250).End(xlToLeft).Column - 1
'Call macro_other1 'Performs calculations and populates columns AI and AJ
For model = 1 To 8
lastempty = Split(Range("R14").End(xlToLeft).Offset(0, 1).Address, "$")(1)
'STEP1 'Get very first variable
Application.Calculation = xlManual
'Call Macro_Other2 ' Performs others calculations and populates columns AA and AF
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
' Checks to see sign is ok if not deletes variables from list
Sheets("Build-Linear").Range("AK2:AK" & z).Formula = "=sign(Ad2)"
Sheets("Build-Linear").Range("AK2:AK" & z).Value = Range("AK2:AK" & z).Value
Sheets("Build-Linear").Range("AH2:AH" & z).Formula = "=VLookup(AA2, AI$2:AJ$400, 2, False)"
Sheets("Build-Linear").Range("AH2:AH" & z).Value = Range("AH2:AH" & z).Value
Sheets("Build-Linear").Range("AG2:AG" & z).Formula = "=if(ah2=ak2, ""SAME"", ""FALSE"")"
Sheets("Build-Linear").Range("AG2:AG" & z).Value = Range("AG2:AG" & z).Value
Sheets("Build-Linear").Range("AA1:AG" & z).Sort Key1:=Range("AG1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Set rng2 = Sheets("Build-Linear").Range("AG1:AG" & z).Find(What:="FALSE", _
After:=Sheets("Build-Linear").Range("AG1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rng2 Is Nothing Then
Application.GoTo rng2, True

ActiveCell.Select
deletestart = ActiveCell.row
Range("AA" & deletestart & ":AH" & z).Clear
Else
End If

Range("AF2:AF" & z).Value = Range("AD2:AD" & z).Value
Range("AF1:AF" & z).Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("AF1").Value = "Abs Sign Value"

'Vary sort column and order by dignostic criteria selected
Select Case Sheets("Build-Linear").Range("IS1").Value
Case 1 'Diagnostic1
sortcol = 32
sortdirect = xlDescending

Case 2 'Diagnostic2
sortcol = 28
sortdirect = xlDescending

Case 3 'Diagnostic3
sortcol = 31
sortdirect = xlAscending
End Select
Range("AA1:AH" & z).Sort Key1:=Cells(1, sortcol), Order1:=sortdirect, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Get the variable with highest ankin and paste into column U
k = Sheets("Build-Linear").Range("AA1").End(xlDown).row
For i = 2 To k
var1 = Cells(i, 27).Value 'Range("AA2").Value 'set variable at the top of the sorted list as the one with biggest zscore
Set rng = Sheets("X Variables").Rows("1:1").Find(What:=var1, _
After:=Sheets("X Variables").Range("a1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If rng Is Nothing Then
MsgBox "Nothing found for row " & i
Else

'****DOES NOT WORK*******

y = rng.Column 'defines col to copy
Sheets("X Variables").Range(Cells(1, y), Cells(Lastrow, y)).Copy
'Sheets("Build-Linear").Select
'Range("U14").PasteSpecial Paste:=xlPasteValues

Sheets("Build-Linear").Range("U14").PasteSpecial Paste:=xlPasteValues 'Does no work


'CALCULATE STATS
lastvar = Split(Range("R14").End(xlToLeft).Address, "$")(1) 'address bring back the cell address, splits on takes the letter from address
'Call macro_other3 'performs calculations for each variable that is populated in column u from above - his populates cells W4
pvalue = Range("W4").Value
If Abs(pvalue) > Range("c7").Value Then
h = Range("R14").End(xlToLeft).Offset(0, 1).Column
Sheets("Build-Linear").Range(Cells(14, h), Cells(Lastrow, h)).Value = Sheets("Build-Linear").Range(Cells(14, 21), Cells(Lastrow, 21)).Value

'Call macro_other4 'calculates data and populates rows 2 to 6 starting column D for each variable added from above

'Application.Calculation = xlManual
existrange = Range("B14").End(xlToRight).Column 'last estimated variable
critz = "<" & Range("c7").Value
'
If WorksheetFunction.CountIf(Range(Cells(6, 4), Cells(6, existrange)), critz) >= 1 Then 'need to change to look abs value of t-stat
s = Range("R14").End(xlToLeft).Column
Range(Cells(14, s), Cells(Lastrow, s)).ClearContents
Range(Cells(3, s), Cells(5, s)).ClearContents
End If
End If
End If
'End If
Next i
'Call macro_other4 'calculates data and populates rows 2 to 6 starting column D for each variable added from above
flg = Range(lastempty & "14").Value
If flg = "" Then Exit For
Next model
Application.DisplayStatusBar = True
End Sub

Teeroy
10-15-2012, 04:40 AM
I've found for PasteSpecial to work correctly I need to activate the destination sheet.

Jamyhamy
10-15-2012, 04:47 AM
Yep I agree.

For example in the orginal code for that section, when I select the sheet Build-Linear, the code works. But note here that the conditional if function used slightly differently.

k = Sheets("Build-Linear").Range("AA1").End(xlDown).row
For i = 2 To k
var1 = Cells(i, 27).Value 'Range("AA2").Value 'set variable at the top of the sorted list as the one with biggest zscore
If Sheets("Build-Linear").Range(lastempty & "14") = "" Then 'only run until an X has been entered into the model
Set rng = Sheets("X Variables").Rows("1:1").Find(What:=var1, _
After:=Sheets("X Variables").Range("a1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rng Is Nothing Then
Application.GoTo rng, True
Else
MsgBox "Nothing found for row " & i
End If

y = rng.Column 'defines col to copy
Range(Cells(1, y), Cells(Lastrow, y)).Copy
Sheets("Build-Linear").Select
Range("U14").PasteSpecial Paste:=xlPasteValues

Teeroy
10-15-2012, 02:06 PM
OK I think the CELLS method is unable to identify the object it is supposed to apply to. Try fully referencing it by replacing the non-working portion with:

With Sheets("X Variables")
y = rng.Column 'defines col to copy
.Range(.Cells(1, y), .Cells(lastrow, y)).Copy
Sheets("Build-Linear").Range("U14").PasteSpecial Paste:=xlPasteValues
End With

Jamyhamy
10-17-2012, 03:19 PM
Thanks Teeroy,

I've tried this out and it works fine!

Though hardly makes any diiference to speed of the code!