Sub HistoricalAnalogs_2Var()
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X This macro returns a set of distance measures relating the similarity of X
'X a series of historical price changes to the current sample X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X define source data for total sample array X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim DataSht As String: DataSht = ActiveSheet.Range("C4").value
Dim samplerange As String: samplerange = ActiveSheet.Range("C5").value
Dim PriceData As Variant: PriceData = Worksheets(DataSht).Range(samplerange).value
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X define source data for target sample array X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim DataRange As String: DataRange = ActiveSheet.Range("C6").value
Dim X As Variant: X = Worksheets(DataSht).Range(DataRange).value
Dim A As Integer: A = UBound(PriceData, 1) ' A is the population size and contains full set of test sets
Dim NumObs As Integer: NumObs = UBound(X, 1) ' NumObs is the sample size
Dim TempSample() As Variant: ReDim TempSample(1 To NumObs, 1 To 3)
Dim ArrX() As Variant: ReDim ArrX(1 To NumObs)
Dim ArrX1() As Variant: ReDim ArrX1(1 To NumObs)
Dim ArrTemp() As Variant: ReDim ArrTemp(1 To NumObs)
Dim ArrTemp1() As Variant: ReDim ArrTemp1(1 To NumObs)
Dim DistanceMeasure As Integer
Dim DistanceMeasure1 As Integer
Dim ii As Integer: 'total sample length
Dim oo As Integer:
Dim nn As Integer: nn = 1
Dim rr As Integer:
Dim jj As Integer: jj = 5
Dim gg As Integer: gg = 1
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Log transform X array X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
For oo = 1 To NumObs
ArrX(oo) = Application.Log(Application.WorksheetFunction.Index(X, oo, 2), Application.WorksheetFunction.Index(X, NumObs, 2))
Next oo
'XXXXXXXXXXXXXXXX
'X Main Script X
'XXXXXXXXXXXXXXXX
For ii = NumObs To A - NumObs
For rr = 1 To NumObs
TempSample(rr, 1) = Application.WorksheetFunction.Index(PriceData, ii + rr, 1) 'Dimension 1 TempSample - Date of Temp Sample
TempSample(rr, 2) = Application.WorksheetFunction.Index(PriceData, ii + rr, 2) 'Dimension 2 TempSample - price of Temp Sample
TempSample(rr, 3) = Application.WorksheetFunction.Index(PriceData, ii + rr, 3) 'Dimension 3 TempSample - Volume
Next rr
For nn = 1 To NumObs
ArrTemp(nn) = Application.WorksheetFunction.Log(Application.WorksheetFunction.Index(TempSample, nn, 2), Application.WorksheetFunction.Index(TempSample, NumObs, 2))
Next nn
For gg = 1 To NumObs
ArrX1(gg) = X(gg, 3)
ArrTemp1(gg) = TempSample(gg, 3)
Next gg
DistanceMeasure = (1 - Application.WorksheetFunction.Correl(ArrX, ArrTemp)) * 100
DistanceMeasure1 = (1 - Application.WorksheetFunction.Correl(ArrX1, ArrTemp1)) * 100
Worksheets("AllDistanceMeasures").Cells(jj, 1).value = DistanceMeasure
Worksheets("AllDistanceMeasures").Cells(jj, 2).value = DistanceMeasure1
Worksheets("AllDistanceMeasures").Cells(jj, 3).value = DistanceMeasure + DistanceMeasure1
Worksheets("AllDistanceMeasures").Cells(jj, 4).value = TempSample(NumObs, 1) 'start date
Worksheets("AllDistanceMeasures").Cells(jj, 5).value = TempSample(1, 1) 'end date
jj = jj + 1
Next ii
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'O Sorts distance measures output ascending O
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Worksheets("AllDistanceMeasures").Activate
Range("C5").Select
Selection.CurrentRegion.Sort Key1:=Range("C5"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'O loops through distances and keeps shortest distances with O
'O non-overlapping periods of time O
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Worksheets("AllDistanceMeasures").Activate
Dim kk As Integer: kk = 5
Dim hh As Integer
Dim StartDate1 As Date
Dim EndDate1 As Date
Dim StartDate2 As Date
Dim EndDate2 As Date
Do Until Cells(kk, 3) = ""
StartDate1 = Cells(kk, 4)
EndDate1 = Cells(kk, 5)
hh = kk + 1
Do Until Cells(hh, 3) = ""
StartDate2 = Cells(hh, 4)
EndDate2 = Cells(hh, 5)
If StartDate2 <= StartDate1 And StartDate1 <= EndDate2 And Cells(kk, 3) <= Cells(hh, 3) Then
Cells(hh, 3).Interior.ColorIndex = 5
End If
If StartDate2 <= EndDate1 And EndDate1 <= EndDate2 And Cells(kk, 3) < Cells(hh, 3) Then
Cells(hh, 3).Interior.ColorIndex = 5
End If
hh = hh + 1
Loop
kk = kk + 1
Loop
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Delete overlapping sets X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim mm As Integer
Dim ll As Integer: ll = Range("C5").End(xlDown).Row
ActiveWorkbook.Worksheets("AllDistanceMeasures").Activate
For mm = ll To 5 Step -1
If Cells(mm, 3).Interior.ColorIndex = 5 Then
Rows(mm).EntireRow.Delete
End If
Next mm
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Copy 20 Lowest distance measures to new columns X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ActiveWorkbook.Worksheets("AllDistanceMeasures").Activate
Range("A5:E24").Copy
Range("G5").PasteSpecial xlPasteValues
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Produce line charts for low distance sample and output into "charts" sheet X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim aa As Integer
Dim StartDate As String
Dim EndDate As String
Dim RngStart As Range
Dim RngEnd As Range
Dim RngStartR As String
Dim RngEndR As String
Dim RngFutureR As String
Dim RngXR As String:
Dim RngXR2 As String:
Dim sh As Worksheet
Dim chrt As ChartObject
Dim chrt1 As ChartObject
Dim ch As Chart
Dim ch1 As Chart
Dim zz As Integer
Dim NumObs2 As Long
Dim TempSampleOutput As Variant
Dim RangeVar1 As String
Dim RangeVar2 As String
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Write in X Array Samples to sheet X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
For zz = 1 To NumObs
Sheets("LowDistCharts").Cells(4, 21).Offset(zz, 0).value = ArrX(zz)
Next zz
RngXR = Sheets("LowDistCharts").Range("U5").Address
RngXR2 = Sheets("LowDistCharts").Range("U5").End(xlDown).Address
zz = 1
NumObs2 = Sheets("AllDistanceMeasures").Cells(Rows.Count, 11).End(xlUp).Row
For aa = 5 To NumObs2
StartDate = Sheets("AllDistanceMeasures").Cells(aa, 10).value
EndDate = Sheets("AllDistanceMeasures").Cells(aa, 11).value
If StartDate <> "" Then
Set RngStart = Sheets("ActiveSheet").Cells.Find(What:=StartDate, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 1)
End If
RngStartR = RngStart.Address
If EndDate <> "" Then
Set RngEnd = Sheets("ActiveSheet").Cells.Find(What:=EndDate, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 1)
End If
RngEndR = RngEnd.Address
TempSampleOutput = Sheets("ActiveSheet").Range(RngStartR, RngEndR).value
For nn = 1 To NumObs
ArrTemp(nn) = Application.WorksheetFunction.Log(Application.WorksheetFunction.Index(TempSampleOutput, nn, 1), Application.WorksheetFunction.Index(TempSampleOutput, NumObs, 1))
Next nn
nn = 1
For nn = 1 To NumObs
Sheets("LowDistCharts").Cells(4, aa + 18).Offset(nn, 0).value = ArrTemp(nn)
Next nn
RangeVar1 = Sheets("LowDistCharts").Cells(5, aa + 18).Address
RangeVar2 = Sheets("LowDistCharts").Cells(5, aa + 18).End(xlDown).Address
ActiveWorkbook.Sheets("LowDistCharts").Activate
Set sh = Worksheets("LowDistCharts")
Set chrt = sh.ChartObjects.Add(1, 1 + ((aa - 4) * 300), 300, 300)
Set ch = chrt.Chart
Do While ch.SeriesCollection.Count > 1
ch.SeriesCollection(1).Delete
Loop
With ch
.ChartType = xlLine
.SeriesCollection.NewSeries
.SeriesCollection(1).Values = ActiveWorkbook.Worksheets("LowDistCharts").Range(RngXR, RngXR2)
.SeriesCollection.NewSeries
.SeriesCollection(2).Values = ActiveWorkbook.Worksheets("LowDistCharts").Range(RangeVar1, RangeVar2)
.Axes(xlCategory).ReversePlotOrder = True
.HasLegend = False
.HasTitle = True
.ChartTitle.Text = aa & " " & StartDate & " to " & EndDate
.ChartTitle.Font.Size = 8
.Axes(xlValue).MinimumScale = 0.9
.Axes(xlValue).MaximumScale = 1.1
End With
Next aa
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Produce volume charts for comparable volumes for samples X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim RngVolStart As Range
Dim RngVolEnd As Range
Dim RngVolEndR As String
Dim RngVolStartR As String
Dim chrt2 As ChartObject
Dim ch2 As Chart
Dim RngVolXR As String: RngVolXR = ActiveWorkbook.Sheets("ActiveSheet").Range("C10").value
Dim RngVolXR2 As String: RngVolXR2 = ActiveWorkbook.Sheets("ActiveSheet").Range("C11").value
For aa = 5 To NumObs2
StartDate = Sheets("AllDistanceMeasures").Cells(aa, 10).value
EndDate = Sheets("AllDistanceMeasures").Cells(aa, 11).value
Set RngVolStart = Sheets("ActiveSheet").Cells.Find(What:=StartDate, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 2)
RngVolStartR = RngVolStart.Address
Set RngVolEnd = Sheets("ActiveSheet").Cells.Find(What:=EndDate, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 2)
RngVolEndR = RngVolEnd.Address
ActiveWorkbook.Sheets("LowDistCharts").Activate
Set chrt2 = sh.ChartObjects.Add(300, 1 + ((aa - 4) * 300), 300, 300)
Set ch2 = chrt2.Chart
Do While ch2.SeriesCollection.Count > 1
ch2.SeriesCollection(1).Delete
Loop
With ch2
.ChartType = xlColumnStacked
.HasLegend = False
.SeriesCollection.NewSeries
.SeriesCollection(1).Values = ActiveWorkbook.Worksheets("ActiveSheet").Range(RngVolXR, RngVolXR2)
.SeriesCollection.NewSeries
.SeriesCollection(2).Values = ActiveWorkbook.Worksheets("ActiveSheet").Range(RngVolStartR, RngVolEndR)
.Axes(xlCategory).ReversePlotOrder = True
.HasLegend = False
.HasTitle = True
.ChartTitle.Text = "Vol " & aa & " " & "StartDate" & " to " & "EndDate"
.ChartTitle.Font.Size = 8
End With
For zz = 1 To NumObs
If RngEnd.Row >= 31 Then
Sheets("ActiveSheet").Range(RngVolStartR).Offset(-zz, 0).Copy
Sheets("LowDistCharts").Cells(4, aa + 39).Offset(zz, 0).PasteSpecial xlPasteValues
End If
Next zz
Next aa
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Produce charts and sample series for low distance sets for 25 samples after X
'X end date X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim RangeFuture As Variant
Dim ArrFut As Variant: ReDim ArrFut(1 To 25) As Variant
Dim RngFut1 As String
Dim RngFut2 As String
For aa = 5 To NumObs2
EndDate = Sheets("AllDistanceMeasures").Cells(aa, 11).value
If EndDate <> "" Then
Set RngEnd = Sheets("ActiveSheet").Cells.Find(What:=EndDate, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 1)
End If
RngEndR = RngEnd.Address
If RngEnd.Row < 31 Then
RngFutureR = "F6"
Else
RngFutureR = RngEnd.Offset(-25, 0).Address
End If
oo = 1
RangeFuture = Sheets("ActiveSheet").Range(RngEndR, RngFutureR).value
For oo = 1 To 25
ArrFut(oo) = Application.WorksheetFunction.Log(Application.WorksheetFunction.Index(RangeFuture, oo, 1), Application.WorksheetFunction.Index(RangeFuture, 25, 1))
Next oo
oo = 1
For oo = 1 To 25
Sheets("LowDistCharts").Cells(4, aa + 60).Offset(oo, 0).value = ArrFut(oo)
Next oo
RngFut1 = Sheets("LowDistCharts").Cells(5, aa + 60).Address
RngFut2 = Sheets("LowDistCharts").Cells(5, aa + 60).End(xlDown).Address
ActiveWorkbook.Sheets("LowDistCharts").Activate
Set chrt1 = sh.ChartObjects.Add(600, 1 + ((aa - 4) * 300), 300, 300)
Set ch1 = chrt1.Chart
Do While ch1.SeriesCollection.Count > 1
ch1.SeriesCollection(1).Delete
Loop
With ch1
.ChartType = xlLine
.HasLegend = False
.SeriesCollection.NewSeries
.SeriesCollection(1).Values = ActiveWorkbook.Worksheets("LowDistCharts").Range(RngFut1, RngFut2)
.Axes(xlCategory).ReversePlotOrder = True
.Axes(xlValue).MinimumScale = 0.9
.Axes(xlValue).MaximumScale = 1.1
.HasTitle = True
.ChartTitle.Text = aa & " " & EndDate & " to " & "Future 25"
.ChartTitle.Font.Size = 8
End With
Next aa
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'X Summary statistics for low dist future walks X
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim NumObs3 As Integer: NumObs3 = Sheets("LowDistCharts").Cells(Rows.Count, 84).End(xlUp).Row
Sheets("LowDistCharts").Cells(4, 85).value = "Average"
Sheets("LowDistCharts").Cells(4, 86).value = "Stdev"
Sheets("LowDistCharts").Cells(4, 87).value = "Skew"
For aa = 5 To NumObs3
On Error Resume Next
Sheets("LowDistCharts").Cells(aa, 85).value = Application.WorksheetFunction.Average(Range(Cells(aa, 65), Cells(aa, 84)))
Sheets("LowDistCharts").Cells(aa, 86).value = Application.WorksheetFunction.StDev(Range(Cells(aa, 65), Cells(aa, 84)))
Sheets("LowDistCharts").Cells(aa, 87).value = Application.WorksheetFunction.Skew(Range(Cells(aa, 65), Cells(aa, 84)))
Next aa
End Sub