Efficient Macro

[Tian1]

Hallo,

I have got the following code which correcty puts various text in the required cells. I'm going to have to do this for a lot of loops and would thus just like to know if there is a more efficient way of achieving this. The code below is probably the most inefficient code to do what I would like to do.

Sub ResultCopy()

j = 1
For i = 1 To 24

Range("A" & i) = "Strategy " '& j
Range("B" & i) = j
    i = i + 1
    j = j + 1
    
Range("A" & i) = "Initial DD"
    i = i + 1
    
Range("A" & i) = "DD Increase"
    i = i + 1
    
Range("A" & i) = "1st YoR"
    i = i + 1
    
Range("A" & i) = "Life expectency"
    i = i + 1
    
Range("A" & i) = "AA"
Range("B" & i) = "ALSI"
Range("C" & i) = "ALBI"
Range("D" & i) = "Top40"
Range("E" & i) = "SA Property"
Range("F" & i) = "Int Equity"
Range("G" & i) = "Int Bonds"

    i = i + 2
    
Range("A" & i) = "Present Value"
    i = i + 1

Range("A" & i) = "Annuity"
    i = i + 1

Range("A" & i) = "Terminal Value"
    i = i + 1

Range("A" & i) = "Total"
    i = i + 1
    
Next i
End sub

 

[hiker95]

Tian1,

Here are the results for an input for 2 Strategy Tables (you will only be able to see column A's HorizontalAlignment = xlCenter because of the text data in column A):

Excel 2007
	A	B	C	D	E	F	G
1	Strategy	1
2	Initial DD
3	DD Increase
4	1 st YoR
5	Life expectency
6	AA	ALSI	ALBI	Top40	SA Property	Int Equity	Int Bonds
7
8	Present Value
9	Annuity
10	Terminal Value
11	Total
12
13	Strategy	2
14	Initial DD
15	DD Increase
16	1 st YoR
17	Life expectency
18	AA	ALSI	ALBI	Top40	SA Property	Int Equity	Int Bonds
19
20	Present Value
21	Annuity
22	Terminal Value
23	Total
24
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub CreateStrategyTables_V4()
' hiker95, 10/15/2014, ME805507
Dim a As Variant, i As Long, n As Long, lr As Long, c As Long, rc As Long
On Error GoTo MyExit
n = InputBox("Enter the number of 'Strategy Tables' that you require?")
If n <= 0 Then GoTo MyExit:
rc = Rows.Count
lr = n * 12
If lr > rc Then GoTo NotEnoughRows
Application.ScreenUpdating = False
ReDim a(1 To lr, 1 To 7)
For i = 1 To lr Step 12
  c = c + 1
  If c = 5 Then c = 1
  Sheets("Calcs").Range("B4") = c
  a(i, 1) = "Strategy": a(i, 2) = c
  a(i + 1, 1) = "Initial DD"
  a(i + 2, 1) = "DD Increase"
  a(i + 3, 1) = "1 st YoR"
  a(i + 4, 1) = "Life expectency"
  a(i + 5, 1) = "AA": a(i + 5, 2) = "ALSI": a(i + 5, 3) = "ALBI": a(i + 5, 4) = "Top40"
  a(i + 5, 5) = "SA Property": a(i + 5, 6) = "Int Equity": a(i + 5, 7) = "Int Bonds"
  a(i + 7, 1) = "Present Value"
  a(i + 8, 1) = "Annuity"
  a(i + 9, 1) = "Terminal Value"
  a(i + 10, 1) = "Total"
Next i
Columns("A:G").ClearContents
Range("A1").Resize(lr, 7).Value = a
For i = 6 To lr Step 12
  Range("A" & i & ":G" & i).HorizontalAlignment = xlCenter
Next i
Columns("A:G").AutoFit
Application.ScreenUpdating = True
Exit Sub
NotEnoughRows:
MsgBox "You do not have enough sheet rows to display the number of " & vbLf & " 'Strategy Tables' that you require - macro terminated!"
Exit Sub
MyExit:
On Error GoTo 0
MsgBox "You did not enter a number greater than 0 - macro terminated!"
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the CreateStrategyTables_V4 macro.

 

[Tian1]

Hiker95,

I am still working on this thread's problem, and have got the following code:

Sub CreateStrategyTables_V4()

Dim a As Variant
Dim i As Long
Dim incr As Long
Dim stratnumber As Long
Dim lr As Long
Dim rc As Long
Dim SNcount As Long
Dim AA As Long
Dim RetireeCase As Long
Dim Idd1 As Double


On Error GoTo MyExit
stratnumber = Application.InputBox("Enter the number of 'Strategy Tables' that you require?")
Application.ScreenUpdating = False

Idd1 = 0.025
stratnumbercount = 0
AA = 0
RetireeCase = 1

For CopyR = 3 To 4
    'ALSI
    Workbooks("Monte Carlo (P).xlsm").Worksheets("ALSI").Range("B" & CopyR & ":RM" & CopyR).Copy
    Workbooks("Living annuity 1 Jan.1.xlsm").Worksheets("Returns").Range("C2:C481").PasteSpecial Transpose:=True
    
    'ALBI
    Workbooks("Monte Carlo (P).xlsm").Worksheets("ALBI").Range("B" & CopyR & ":RM" & CopyR).Copy
    Workbooks("Living annuity 1 Jan.1.xlsm").Worksheets("Returns").Range("D2:D481").PasteSpecial Transpose:=True
    
    'TOP40
    Workbooks("Monte Carlo (P).xlsm").Worksheets("TOP40").Range("B" & CopyR & ":RM" & CopyR).Copy
    Workbooks("Living annuity 1 Jan.1.xlsm").Worksheets("Returns").Range("E2:E481").PasteSpecial Transpose:=True
    
    'SA Prop
    Workbooks("Monte Carlo (P).xlsm").Worksheets("SA Property").Range("B" & CopyR & ":RM" & CopyR).Copy
    Workbooks("Living annuity 1 Jan.1.xlsm").Worksheets("Returns").Range("F2:F481").PasteSpecial Transpose:=True
    
    'Int E
    Workbooks("Monte Carlo (P).xlsm").Worksheets("Int Equity").Range("B" & CopyR & ":RM" & CopyR).Copy
    Workbooks("Living annuity 1 Jan.1.xlsm").Worksheets("Returns").Range("G2:G481").PasteSpecial Transpose:=True
    
    'Int B
    Workbooks("Monte Carlo (P).xlsm").Worksheets("Int Bonds").Range("B" & CopyR & ":RM" & CopyR).Copy
    Workbooks("Living annuity 1 Jan.1.xlsm").Worksheets("Returns").Range("H2:H481").PasteSpecial Transpose:=True
    
    'CPI
    Workbooks("Monte Carlo (P).xlsm").Worksheets("CPI").Range("B" & CopyR & ":RM" & CopyR).Copy
    Workbooks("Living annuity 1 Jan.1.xlsm").Worksheets("Returns").Range("I2:I481").PasteSpecial Transpose:=True

'Run Code
    Worksheets("All results").Activate
    
    
    If stratnumber <= 0 Then GoTo MyExit:
        rc = Rows.Count
        lr = stratnumber * 11
            
            If lr > rc Then GoTo NotEnoughRows
                Application.ScreenUpdating = False
                ReDim a(1 To lr, 1 To 2)
                                  
                For i = 1 To lr Step 11
                    SNcount = SNcount + 1
                    
                    'AA, Idd, Retireecase
                    AA = AA + 1
                                    
                    If AA = 5 Then
                        Idd1 = Idd1 + 0.025
                        
                        If Idd1 = 0.1 Then
                            Idd1 = 0.025
                        End If
                    
                    AA = 1
                    
                    End If
                                   
                    
                    If (SNcount - 1) / 12 = Int((SNcount - 1) / 12) And SNcount <> 1 Then
                        RetireeCase = RetireeCase + 1
                            If RetireeCase = 9 Then
                                RetireeCase = 1
                            End If
                    End If
                    
                                    
                    'SET AA
                    Worksheets("Calcs").Range("B4") = AA
                                   
                    'STRATEGY NUMBER
                    a(i, 1) = "Strategy": a(i, 2) = SNcount
                    
                    'SET INITIAL DD
                    a(i + 1, 1) = "Initial DD"
                    Worksheets("Calcs").Range("C2") = Idd1
                    a(i + 1, 2) = Worksheets("Calcs").Range("C2")
                    
                    a(i + 2, 1) = "DD Increase"
                  
                    
                    'LIFE EXPENTANCY
                    a(i + 3, 1) = "Retiree Case"
                                    
                    Worksheets("Calcs").Range("F1") = RetireeCase
                    a(i + 3, 2) = Worksheets("Calcs").Range("F1")
                    
                    a(i + 4, 1) = "Life expectency (MAX)"
                    a(i + 4, 2) = Worksheets("Results").Range("K4")
                                        
                                            
                    'RESULTS COPIED
                    a(i + 5, 1) = "AA"
                    a(i + 5, 2) = Worksheets("Calcs").Range("B4")
                    a(i + 6, 1) = "Present Value"
                    a(i + 7, 1) = "Annuity"
                    a(i + 7, 2) = Worksheets("Results").Range("N2")
                    a(i + 8, 1) = "Terminal Value"
                    a(i + 8, 2) = Worksheets("Results").Range("N3")
                    a(i + 9, 1) = "Total"
                    a(i + 9, 2) = Worksheets("Results").Range("N4")
                                                  
                Next i
                
        Range("A2").Resize(lr, 2).Value = a
        Columns("A:B").AutoFit
        'Application.ScreenUpdating = True

Next CopyR
        
'Error Handling
    Exit Sub
    
NotEnoughRows:
    MsgBox "You do not have enough sheet rows to display the number of " & vbLf & " 'Strategy Tables' that you require - macro terminated!"
    
    Exit Sub
    
MyExit:
    On Error GoTo 0
    MsgBox "You did not enter a number greater than 0 - macro terminated!"

End Sub

Basically, what happens in the code above is very similar to you original code only I have added the CopyR FOR loop.

The idea is to repeat your original code through the CopyR loop, but everytime the code is repeated, it should start three columns from the previous (please see the table below)

What I would like to achieve is something along the lines of the table below:

	A	B	C	D	E
1	Strategy <tbody> </tbody>	value	blank column	Strategy	value
2	Initial DD <tbody> </tbody>	value		Initial DD	value
3	DD Increase <tbody> </tbody>	value		DD Increase	value
4	Retiree Case <tbody> </tbody>	value		Retiree Case	value
5	Life expectency <tbody> </tbody>	value		Life expectency	value
6	AA <tbody> </tbody>	value		AA	value
7	Present Value <tbody> </tbody>	value		Present Value	value
8	Annuity <tbody> </tbody>	value		Annuity	value
9	Terminal Value <tbody> </tbody>	value		Terminal Value	value
10	Total <tbody> </tbody>	value		Total	value

<tbody>
</tbody>

A final note is that it will run for quite a few more times than the 3 to 4 specified in the code above. I just loop it twice to test is out.

Thanks very much in advance, and a happy new year for you!

p.s. I'm using Excel 2013, and it's on my PC.

 

[hiker95]

Tian1,

And, a Happy New Year to you.

In order to continue I would like to see your workbook/worksheets.

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

 

[Tian1]

Hallo Hiker95,

I've actually simplified the problem to the following code:

Sub CreateStrategyTables_V7()

Dim a As Variant
Dim i As Long
Dim incr As Long
Dim stratnumber As Long
Dim lr As Long
Dim rc As Long
Dim SNcount As Long
Dim AA As Long
Dim RetireeCase As Long
Dim Idd1 As Double


On Error GoTo MyExit
stratnumber = Application.InputBox("Enter the number of 'Strategy Tables' that you require?")
Application.ScreenUpdating = False

    Worksheets("Sheet1").Activate
            
        
    If stratnumber <= 0 Then GoTo MyExit:
    rc = Rows.Count
    lr = stratnumber * 3
    col = stratnumber * 3
            
    If lr > rc Then GoTo NotEnoughRows
    Application.ScreenUpdating = False
    
    'Array
    ReDim a(1 To lr, 1 To col)
                        
    For r = 1 To lr Step 3 'Step 3 skips every third cell (NB - lr = stratnumber * X)
                  
        For c = 1 To col Step 3
        
            SNcount = SNcount + 1
            
            'STRATEGY NUMBER
            a(c, r) = "Strategy": a(c, r + 1) = SNcount
            
             'RESULTS COPIED
            a(c + 1, r) = "AA"
            a(c + 1, r + 1) = "X"
            
            If SNcount = stratnumber + 1 Then
                SNcount = 1
            End If
                                                                                                  
          Next c
          
    Next r
                
    Range("A2").Resize(lr, col).Value = a
            
'Error Handling
    Exit Sub
    
NotEnoughRows:
    MsgBox "You do not have enough sheet rows to display the number of " & vbLf & " 'Strategy Tables' that you require - macro terminated!"
    
    Exit Sub
    
MyExit:
    On Error GoTo 0
    MsgBox "You did not enter a number greater than 0 - macro terminated!"

End Sub

You can run this in your workbook. It works as I want it to, except for one error:
If, for example, you enter 4, the values in cells E2, H2, K2 all equal 5. They should, however, equal one.

If you could assist me in this regard I'd appreciate it very much!

Thanks.

 

[Tian1]

Turns out the IF should just be stated a bit earlier in the code. Thanks anyway!

 

[Rick Rothstein]

I hate when old threads are reactivated... I always miss the fact that the posting date occurred in the "distant" past. Below is code I developed before I realized this was an old thread, but I am posting it because the OP and other readers might find interesting given it some five times faster (at least on my computer) than the code hiker95 posted back in Message #11 (it is also a few lines shorter as well)...

Sub CreateStrategyTables()
  Dim X As Long, n As Variant
  n = Application.InputBox("Enter the number of 'Strategy Tables' that you require?")
  If Len(n) = 0 Or Val(n) <= 0 Or Not n Like String(Len(n), "#") Then
    MsgBox "You did not enter an integer number greater than 0 - macro terminated!"
  Else
    Range("B1").Value = 1
    Range("A1:A11").Value = [{"Strategy";"Initial DD";"DD Increase";"1 st YoR";"Life expectency";"AA";"";"Present Value";"Annuity";"Terminal Value";"Total"}]
    Range("B6:G6") = [{"ALSI","ALBI","Top40","SA Property","Int Equity","Int Bonds"}]
    Range("A6:G6").HorizontalAlignment = xlCenter
    Range("A1:G12").AutoFill Destination:=Range("A1:G" & 12 * n), Type:=xlFillDefault
    Columns("A:G").AutoFit
  End If
End Sub

Note: There is one very long code line above that word wraps (sorry, but it cannot be line-continued), but don't worry as it will "straighten out" when you copy/paste the code above into your code module.

 

[Tian1]

Thanks Rick!

I'm still working on the problem, so this is nevertheless still very valuable to me, thank you.

 

[hiker95]

Turns out the IF should just be stated a bit earlier in the code. Thanks anyway!

Tian1,

I sounds like you have figured it out.

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

 

[Tian1]

Hallo Hiker95,

Perhaps you can assist me with the following:

Sub TCPPRun3()

Dim a As Variant
Dim Iteration As Long
Dim totalrows As Long
Dim totalcols As Long
Dim RetireeCase As Integer
Dim CopyR As Integer

Iteration = Application.InputBox("Enter the number of iterations?")
Application.ScreenUpdating = False

CopyR = 3
RetireeCase = 1

Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Calcs").Range("E1") = RetireeCase
   
totalrows = Iteration
             
ReDim a(1 To 5, 1 To 5)
                
For outcol = 1 To 5
                      
        For inrow = 1 To 5
        
            'Copy Returns
            'TOP40
            Workbooks("(Final Rfr) Monte Carlo.xlsm").Worksheets("TOP40").Range("B" & CopyR & ":RM" & CopyR).Copy
            Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Returns").Range("D2:D481").PasteSpecial Transpose:=True
                                
            'ALBI
            Workbooks("(Final Rfr) Monte Carlo.xlsm").Worksheets("ALBI").Range("B" & CopyR & ":RM" & CopyR).Copy
            Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Returns").Range("E2:E481").PasteSpecial Transpose:=True
                                       
            'CPI
            Workbooks("(Final Rfr) Monte Carlo.xlsm").Worksheets("CPI").Range("B" & CopyR & ":RM" & CopyR).Copy
            Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Returns").Range("F2:F481").PasteSpecial Transpose:=True
                
            a(inrow, outcol) = Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Calcs").Range("H6")
                                     
            CopyR = CopyR + 1
            
        Next inrow
        
    RetireeCase = RetireeCase + 1
               
    Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Calcs").Range("E1") = RetireeCase
            
    outcol = outcol + 2
    
Next outcol
                
Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("All Results").Range("B3").Resize(5, 5).Value = a

End Sub

This code places values in the ranges B3:B7, then E3:E7 (this pattern will eventually continue - the code is just a scaled-down version)

My problem is that by making use of the array it overrides all the information in the cells in-between B3:B7 and E3:E7. I would like the code to skip from column B to E, and not to delete the current values in this in-between range.

Hope you can help? I suspect it's got to do with declaring the array-size (Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("All Results").Range("B3").Resize(5, 5).Value = a)

Thanks!

 

[Rick Rothstein]

Hallo Hiker95,

Perhaps you can assist me with the following:

Sub TCPPRun3()

Dim a As Variant
Dim Iteration As Long
Dim totalrows As Long
Dim totalcols As Long
Dim RetireeCase As Integer
Dim CopyR As Integer

Iteration = Application.InputBox("Enter the number of iterations?")
Application.ScreenUpdating = False

CopyR = 3
RetireeCase = 1

Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Calcs").Range("E1") = RetireeCase
   
totalrows = Iteration
             
ReDim a(1 To 5, 1 To 5)
                
For outcol = 1 To 5
                      
        For inrow = 1 To 5
        
            'Copy Returns
            'TOP40
            Workbooks("(Final Rfr) Monte Carlo.xlsm").Worksheets("TOP40").Range("B" & CopyR & ":RM" & CopyR).Copy
            Workbooks("TCPP 18 Jan (CPI).xlsm").Worksheets("Returns").Range("D2:D481").PasteSpecial Transpose:=True
       .....
       ....

This code places values in the ranges B3:B7, then E3:E7 (this pattern will eventually continue - the code is just a scaled-down version)

My problem is that by making use of the array it overrides all the information in the cells in-between B3:B7 and E3:E7. I would like the code to skip from column B to E, and not to delete the current values in this in-between range.

I think changing the red highlighted line of code to the following will do what you want. Then, in the future, you just change the 5 (for Column E) to whatever maximum column number you want to process...

For outcol = 2 to 5 Step 3