hweih

New Member
Joined
Apr 10, 2018
Messages
4
Hello all,

I recorded a macro that correlates a price series against an ascending sequence of numbers. The key steps are:

1) populate the adjacent column with ascending numbers i.e. 1,2,3,4,5...
2) Use the correl function to find the correlation between the price and the ascending numbers. A rolling interval of 5 rows was used in this case.
3) Use the data analysis toolpak to plot a histogram showing the % frequency of each bin in the correlation range of -1 to +1.

Unfortunately this macro will not work on any price series that has fewer rows than the original one. I probably need a sort of loop function that continues the process until the price data runs out. Could anyone please provide some guidance on how to implement this loop?


Code:
Sub correlation()'
' correlation Macro
'


'
    ActiveCell.FormulaR1C1 = "1"
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "3"
    Range("C2:C4").Select
    Selection.AutoFill Destination:=Range("C2:C101"), Type:=xlFillDefault
    Range("C2:C101").Select
    ActiveWindow.SmallScroll Down:=-87
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "=CORREL(R[-4]C[-2]:RC[-2],R[-4]C[-1]:RC[-1])"
    Range("D6").Select
    Selection.AutoFill Destination:=Range("D6:D101"), Type:=xlFillDefault
    Range("D6:D101").Select
    ActiveWindow.SmallScroll Down:=-102
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "-1"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "-0.95"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "-0.9"
    Range("F2:F4").Select
    Selection.AutoFill Destination:=Range("F2:F43"), Type:=xlFillDefault
    Range("F2:F43").Select
    ActiveWindow.SmallScroll Down:=-57
    Range("H2").Select
     Application.Run "ATPVBAEN.XLAM!Histogram", ActiveSheet.Range("$D$6:$D$101") _
        , ActiveSheet.Range("$H$2"), ActiveSheet.Range("$F$2:$F$43"), False, False _
        , True, False
    ActiveSheet.Shapes(1).ScaleWidth 2.6614583333, msoFalse, _
        msoScaleFromTopLeft
    ActiveSheet.Shapes(1).ScaleHeight 2.705, msoFalse, msoScaleFromTopLeft
    Range("I3").Select
    ActiveWindow.SmallScroll Down:=21
    Range("H45").Select
    Selection.ClearContents
    Range("I45").Select
    Selection.ClearContents
    Range("I46").Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-43]C:R[-2]C)"
    Range("I47").Select
    ActiveWindow.SmallScroll Down:=-39
    Range("J3").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]/R46C9*100"
    Range("J3").Select
    Selection.AutoFill Destination:=Range("J3:J44"), Type:=xlFillDefault
    Range("J3:J44").Select
    ActiveWindow.SmallScroll Down:=-30
    ActiveSheet.ChartObjects(1).Activate
    ActiveChart.PlotArea.Select
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    ActiveChart.FullSeriesCollection(1).Values = "=Sheet1!$J$3:$J$44"
    ActiveChart.Axes(xlCategory).Select
    ActiveChart.Axes(xlCategory).AxisBetweenCategories = False
    Application.CommandBars("Format Object").Visible = False
    Range("Q38").Select
    ActiveWindow.SmallScroll Down:=-6
    Range("L32").Select
    ActiveCell.FormulaR1C1 = "0.7"
    Range("L33").Select
    ActiveCell.FormulaR1C1 = "-0.7"
    Range("L32:M33").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
    Range("M32").Select
    ActiveWindow.SmallScroll Down:=-9
    ActiveCell.FormulaR1C1 = "=SUM(R[-28]C[-3]:R[-23]C[-3])"
    Range("M33").Select
    ActiveWindow.SmallScroll Down:=12
    ActiveCell.FormulaR1C1 = "=SUM(R[5]C[-3]:R[10]C[-3])"
    Range("M34").Select
    ActiveWindow.SmallScroll Down:=-51
End Sub
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Hello.

You don't need a loop. Calculate where the last row of the pricelist is and incorporate that row number in the appropriate ranges. See the code below.
note: I also streamlined the code, because in a recorded macro there are always constructs with select <range> followed by selection..<something> or activecel..<something>, which I replaced with <range>.<something>

Code:
Sub correlation2()
    Dim lastRow
    
    With ActiveSheet
        lastRow = .Range("B2").End(xlDown).Row
        
        .Range("C:D").Clear
        .Range("C2").FormulaR1C1 = "1"
        .Range("C3").FormulaR1C1 = "2"
        .Range("C4").FormulaR1C1 = "3"
        .Range("C2:C4").AutoFill Destination:=Range("C2:C" & lastRow), Type:=xlFillDefault
        
        .Range("D6").FormulaR1C1 = "=CORREL(R[-4]C[-2]:RC[-2],R[-4]C[-1]:RC[-1])"
        .Range("D6").AutoFill Destination:=Range("D6:D" & lastRow), Type:=xlFillDefault
        
        .Range("F2").FormulaR1C1 = "-1"
        .Range("F3").FormulaR1C1 = "-0.95"
        .Range("F4").FormulaR1C1 = "-0.9"
        .Range("F2:F4").AutoFill Destination:=Range("F2:F43"), Type:=xlFillDefault
         
         .Range("H:J").Clear: If .ChartObjects.Count > 0 Then .ChartObjects(1).Delete
         Application.Run "ATPVBAEN.XLAM!Histogram", .Range("$D$6:$D$" & lastRow) _
            , .Range("$H$2"), .Range("$F$2:$F$43"), False, False _
            , True, False
        .Shapes(1).Top = 5
        .Shapes(1).ScaleWidth 2.6614583333, msoFalse, msoScaleFromTopLeft
        .Shapes(1).ScaleHeight 2.705, msoFalse, msoScaleFromTopLeft
        
        .Range("H45").ClearContents
        .Range("I45").ClearContents
        .Range("I46").FormulaR1C1 = "=SUM(R[-43]C:R[-2]C)"
        
        .Range("J3").FormulaR1C1 = "=RC[-1]/R46C9*100"
        .Range("J3").AutoFill Destination:=Range("J3:J44"), Type:=xlFillDefault
        
        .ChartObjects(1).Activate
        With ActiveChart
          'why?  .FullSeriesCollection(1).Values = "=Sheet1!$J$3:$J$44"
            .Axes(xlCategory).Select
            .Axes(xlCategory).AxisBetweenCategories = False
        End With
        
        Application.CommandBars("Format Object").Visible = False
        
        .Range("L32").FormulaR1C1 = "0.7"
        .Range("L33").FormulaR1C1 = "-0.7"
        
        With .Range("L32:M33").Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        
        .Range("L32:M33").Font.Bold = True
        
        .Range("M32").FormulaR1C1 = "=SUM(R[-28]C[-3]:R[-23]C[-3])"
        .Range("M33").FormulaR1C1 = "=SUM(R[5]C[-3]:R[10]C[-3])"
    End With
End Sub
 
Upvote 0
Hello.

You don't need a loop. Calculate where the last row of the pricelist is and incorporate that row number in the appropriate ranges. See the code below.
note: I also streamlined the code, because in a recorded macro there are always constructs with select <range> followed by selection..<something> or activecel..<something>, which I replaced with <range>.<something>

Code:
Sub correlation2()
    Dim lastRow
    
    With ActiveSheet
        lastRow = .Range("B2").End(xlDown).Row
        
        .Range("C:D").Clear
        .Range("C2").FormulaR1C1 = "1"
        .Range("C3").FormulaR1C1 = "2"
        .Range("C4").FormulaR1C1 = "3"
        .Range("C2:C4").AutoFill Destination:=Range("C2:C" & lastRow), Type:=xlFillDefault
        
        .Range("D6").FormulaR1C1 = "=CORREL(R[-4]C[-2]:RC[-2],R[-4]C[-1]:RC[-1])"
        .Range("D6").AutoFill Destination:=Range("D6:D" & lastRow), Type:=xlFillDefault
        
        .Range("F2").FormulaR1C1 = "-1"
        .Range("F3").FormulaR1C1 = "-0.95"
        .Range("F4").FormulaR1C1 = "-0.9"
        .Range("F2:F4").AutoFill Destination:=Range("F2:F43"), Type:=xlFillDefault
         
         .Range("H:J").Clear: If .ChartObjects.Count > 0 Then .ChartObjects(1).Delete
         Application.Run "ATPVBAEN.XLAM!Histogram", .Range("$D$6:$D$" & lastRow) _
            , .Range("$H$2"), .Range("$F$2:$F$43"), False, False _
            , True, False
        .Shapes(1).Top = 5
        .Shapes(1).ScaleWidth 2.6614583333, msoFalse, msoScaleFromTopLeft
        .Shapes(1).ScaleHeight 2.705, msoFalse, msoScaleFromTopLeft
        
        .Range("H45").ClearContents
        .Range("I45").ClearContents
        .Range("I46").FormulaR1C1 = "=SUM(R[-43]C:R[-2]C)"
        
        .Range("J3").FormulaR1C1 = "=RC[-1]/R46C9*100"
        .Range("J3").AutoFill Destination:=Range("J3:J44"), Type:=xlFillDefault
        
        .ChartObjects(1).Activate
        With ActiveChart
          'why?  .FullSeriesCollection(1).Values = "=Sheet1!$J$3:$J$44"
            .Axes(xlCategory).Select
            .Axes(xlCategory).AxisBetweenCategories = False
        End With
        
        Application.CommandBars("Format Object").Visible = False
        
        .Range("L32").FormulaR1C1 = "0.7"
        .Range("L33").FormulaR1C1 = "-0.7"
        
        With .Range("L32:M33").Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        
        .Range("L32:M33").Font.Bold = True
        
        .Range("M32").FormulaR1C1 = "=SUM(R[-28]C[-3]:R[-23]C[-3])"
        .Range("M33").FormulaR1C1 = "=SUM(R[5]C[-3]:R[10]C[-3])"
    End With
End Sub

Hello ask2tsp,

Thank you for your kind help. Unfortunately I am still new to VBA. Which part of the code do I input the last row number?

</something></range></something></something></range>
 
Upvote 0
Not to speak for anyone, or speak out of turn, but the code given looks for the last used row in column B by itself. You don't have to input anything.
 
Upvote 0
Please just run the macro and see what happens. Then use a shorter or longer pricelist and run the macro again.
 
Upvote 0
Please just run the macro and see what happens. Then use a shorter or longer pricelist and run the macro again.

Thank you! The macro runs perfectly when I change the length of the price list. The only difference is the histogram vertical axis now shows the absolute frequency instead of the % value.

And if I wish to change the number of periods used in the correlation calculation, I only need to change the following line right?

Code:
Range("D6").FormulaR1C1 = "=CORREL(R[-4]C[-2]:RC[-2],R[-4]C[-1]:RC[-1])"
 
Upvote 0
The only difference is the histogram vertical axis now shows the absolute frequency instead of the % value.
Fixed that.

And if I wish to change the number of periods used in the correlation calculation
Changed the code so you enter the number of periods on the sheet in cell B1. No more changing the code.
Code:
Sub correlation2()
    Dim lastRow As Long, runLength As Long, correlStart As Range
    
    With ActiveSheet
        lastRow = .Range("B2").End(xlDown).Row
        runLength = .Range("B1"): Set correlStart = .Cells(1 + runLength, 4)
        
        .Range("C:D").Clear
        .Range("C2") = 1
        .Range("C3") = 2
        .Range("C4") = 3
        .Range("C2:C4").AutoFill Destination:=Range("C2:C" & lastRow), Type:=xlFillDefault

        correlStart.Formula = _
        "=CORREL(" & Range(Cells(correlStart.Row - runLength + 1, 2), Cells(correlStart.Row, 2)).Address(0, 0) & _
               "," & Range(Cells(correlStart.Row - runLength + 1, 3), Cells(correlStart.Row, 3)).Address(0, 0) & ")"
        correlStart.AutoFill Destination:=Range(correlStart, "D" & lastRow), Type:=xlFillDefault
        
        .Range("F2").FormulaR1C1 = "-1"
        .Range("F3").FormulaR1C1 = "-0.95"
        .Range("F4").FormulaR1C1 = "-0.9"
        .Range("F2:F4").AutoFill Destination:=Range("F2:F43"), Type:=xlFillDefault
         
         .Range("H:J").Clear: If .ChartObjects.Count > 0 Then .ChartObjects(1).Delete
         Application.Run "ATPVBAEN.XLAM!Histogram", .Range("$D$6:$D$" & lastRow) _
            , .Range("$H$2"), .Range("$F$2:$F$43"), False, False _
            , True, False
        .Shapes(1).Top = 5
        .Shapes(1).ScaleWidth 2.6614583333, msoFalse, msoScaleFromTopLeft
        .Shapes(1).ScaleHeight 2.705, msoFalse, msoScaleFromTopLeft
        
        .Range("H45").ClearContents
        .Range("I45").ClearContents
        .Range("I46").FormulaR1C1 = "=SUM(R[-43]C:R[-2]C)"
        
        .Range("J3").FormulaR1C1 = "=RC[-1]/R46C9*100"
        .Range("J3").AutoFill Destination:=Range("J3:J44"), Type:=xlFillDefault
        
        .ChartObjects(1).Activate
        With ActiveChart
            .FullSeriesCollection(1).Values = "=Sheet1!$J$3:$J$44"
            .Axes(xlCategory).Select
            .Axes(xlCategory).AxisBetweenCategories = False
        End With
        
        Application.CommandBars("Format Object").Visible = False
        
        .Range("L32").FormulaR1C1 = "0.7"
        .Range("L33").FormulaR1C1 = "-0.7"
        
        With .Range("L32:M33").Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        
        .Range("L32:M33").Font.Bold = True
        
        .Range("M32").FormulaR1C1 = "=SUM(R[-28]C[-3]:R[-23]C[-3])"
        .Range("M33").FormulaR1C1 = "=SUM(R[5]C[-3]:R[10]C[-3])"
    End With
End Sub
 
Upvote 0
Fixed that.


Changed the code so you enter the number of periods on the sheet in cell B1. No more changing the code.
Code:
Sub correlation2()
    Dim lastRow As Long, runLength As Long, correlStart As Range
    
    With ActiveSheet
        lastRow = .Range("B2").End(xlDown).Row
        runLength = .Range("B1"): Set correlStart = .Cells(1 + runLength, 4)
        
        .Range("C:D").Clear
        .Range("C2") = 1
        .Range("C3") = 2
        .Range("C4") = 3
        .Range("C2:C4").AutoFill Destination:=Range("C2:C" & lastRow), Type:=xlFillDefault

        correlStart.Formula = _
        "=CORREL(" & Range(Cells(correlStart.Row - runLength + 1, 2), Cells(correlStart.Row, 2)).Address(0, 0) & _
               "," & Range(Cells(correlStart.Row - runLength + 1, 3), Cells(correlStart.Row, 3)).Address(0, 0) & ")"
        correlStart.AutoFill Destination:=Range(correlStart, "D" & lastRow), Type:=xlFillDefault
        
        .Range("F2").FormulaR1C1 = "-1"
        .Range("F3").FormulaR1C1 = "-0.95"
        .Range("F4").FormulaR1C1 = "-0.9"
        .Range("F2:F4").AutoFill Destination:=Range("F2:F43"), Type:=xlFillDefault
         
         .Range("H:J").Clear: If .ChartObjects.Count > 0 Then .ChartObjects(1).Delete
         Application.Run "ATPVBAEN.XLAM!Histogram", .Range("$D$6:$D$" & lastRow) _
            , .Range("$H$2"), .Range("$F$2:$F$43"), False, False _
            , True, False
        .Shapes(1).Top = 5
        .Shapes(1).ScaleWidth 2.6614583333, msoFalse, msoScaleFromTopLeft
        .Shapes(1).ScaleHeight 2.705, msoFalse, msoScaleFromTopLeft
        
        .Range("H45").ClearContents
        .Range("I45").ClearContents
        .Range("I46").FormulaR1C1 = "=SUM(R[-43]C:R[-2]C)"
        
        .Range("J3").FormulaR1C1 = "=RC[-1]/R46C9*100"
        .Range("J3").AutoFill Destination:=Range("J3:J44"), Type:=xlFillDefault
        
        .ChartObjects(1).Activate
        With ActiveChart
            .FullSeriesCollection(1).Values = "=Sheet1!$J$3:$J$44"
            .Axes(xlCategory).Select
            .Axes(xlCategory).AxisBetweenCategories = False
        End With
        
        Application.CommandBars("Format Object").Visible = False
        
        .Range("L32").FormulaR1C1 = "0.7"
        .Range("L33").FormulaR1C1 = "-0.7"
        
        With .Range("L32:M33").Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        
        .Range("L32:M33").Font.Bold = True
        
        .Range("M32").FormulaR1C1 = "=SUM(R[-28]C[-3]:R[-23]C[-3])"
        .Range("M33").FormulaR1C1 = "=SUM(R[5]C[-3]:R[10]C[-3])"
    End With
End Sub

Thank you so much for your kind help!
 
Upvote 0

Forum statistics

Threads
1,213,526
Messages
6,114,136
Members
448,551
Latest member
Sienna de Souza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top