Speed up excel file (maybe VBA?)

[spanishnick]

Hi,

I have a very large file (100'000+ rows and 40+ columns), each column containing property characteristics. Each property characteristic is assigned a weight on a different sheet (using a combination of Index+Match, i.e. INDEX('Sheet1'!$E$96:$E$143, MATCH(A2, 'Sheet1'!$C$96:$C$143, 0)) and, with this weight, I am estimating the property value by multiplying each weight (so I only have a single column with PRODUCT(INDEX(...), INDEX(...), ....). I would like to give the option for individuals to "play" with the weights and see the impact on total property value, so need the calculations to be updated, and setting manual calculations does not solve the issue as it can still take 2-3 minutes to generate the final output. I was wondering if there was an alternative (i.e. using VBA?).

Thank you

 

[offthelip]

was able to produce the following table (couldn't find an elegant way to multiply all columns in one cell). The computation with 1'226 rows takes about 50 seconds, unsure if there is anything else I could do to speed up the task as I would like to run the similar code on 100'000+ rows.

One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),

I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
The code you added after the code I wrote to do the multiplication is very very slow code because you doing a separate acess to the worksheet for each cell value,
so these lines of code:

For r = 2 To 1226
        Cells(r, 79).Value = Application.WorksheetFunction.Product(Cells(r, 48).Value, Cells(r, 49).Value, Cells(r, 50).Value, Cells(r, 51).Value, Cells(r, 52).Value, Cells(r, 53).Value, Cells(r, 54).Value, Cells(r, 55).Value, Cells(r, 56).Value, Cells(r, 57).Value, Cells(r, 58).Value, Cells(r, 59).Value, Cells(r, 60).Value, Cells(r, 61).Value, Cells(r, 62).Value, Cells(r, 63).Value, Cells(r, 64).Value, Cells(r, 65).Value, Cells(r, 66).Value, Cells(r, 67).Value, Cells(r, 68).Value, Cells(r, 69).Value, Cells(r, 70).Value, Cells(r, 71).Value, Cells(r, 72).Value, Cells(r, 73).Value, Cells(r, 74).Value, Cells(r, 75).Value, Cells(r, 76).Value)
    Next r

you are doing 25 access to the worksheet in a loop of 1225, that is very slow. Almost all the values you need are already in memory, ( I just had to load the square roots in column 80) either because we just calculated them or because we have already loaded all the data in the variant array datr. So I have modified your latest code and run on my machine. with some simplified test data adn it took 60 milliseconds to run. I also created a new variant array to write the outputs into columns AN:AO

Also, I've noticed that the quotient formula is not yielding the correct result but don't understand why this is the case.

this doesn't surprise me because the caculation uses data from column 78 and there doesn't appear to be anyhting in coluumn 78
the latest code:
Sub test()
ts1 = Timer()
Dim Ary As Variant
Dim i As Long
Dim Dic As Object

Set Dic = CreateObject("Scripting.dictionary")
Dim outr()
barray = Array("A2", "F2", "G2", "H2", "I2", "J2", "K2", "L2", "M2", "N2", "O2", "P2", "Q2", "R2", "S2", "T2", "U2", "V2", "W2", "X2", "Y2", "Z2", "AA2", "AB2", "AC2", "AD2", "AE2", "AF2", "AG2", "AH2")
' first convert the column letters in barray to column numbers
ReDim outr(1 To 1226, 1 To UBound(barray) + 1)
For i = 0 To UBound(barray)
tt = Len(barray(i))
If tt = 2 Then
outr(2, i + 1) = Asc(Left(barray(i), 1)) - 64 ' column Number
outr(1, i + 1) = barray(i) ' Column Letter
Else
outr(2, i + 1) = Asc(Mid(barray(i), 2, 1)) - 64 + 26
outr(1, i + 1) = barray(i)
End If
Next i
''''''''''''''''''''''''''''
With Sheets("Baseline Weights")
' Ary = .Range("b5:F167") ' load all the bae line weights into a variant array
Ary = .Range("b5:F161") ' I only have 161 lines of weights
For i = 1 To UBound(Ary)
Dic(Ary(i, 1)) = Ary(i, 5) ' add them all to the dictionary
Next i
End With
''''''''''''''''''''''''''''''
With Sheets("Data")
datr = .Range("A1:Am1226") ' load all the data into a variant array
End With
With Sheets("Data")
.Range("Aq1:Ca1226") = "" ' expand to column Ca (79)
datout = .Range("Aq1:Ca1226") ' load all the data into a variant array

For j = 1 To UBound(barray) ' loop through all the columns
head = datr(1, outr(2, j)) ' pick up header from row 1
datout(1, outr(2, j)) = head
For k = 2 To UBound(datr, 1) ' loop through all the rows
ditem = head & datr(k, outr(2, j))
If Dic.Exists(ditem) Then
datout(k, outr(2, j)) = Dic(ditem) + 1
Else
datout(k, outr(2, j)) = 1
End If
Next k
Next j
' .Range("Aq1:bx1226") = datout
' load the square roots from column CB
squrts = .Range("cb1:cb1226")
testexp = .Range("An1:ao1226")
' Aq is column 42
For r = 2 To 1226
' Note I have to change the addressing here because the variant array datout starts at column Aq i.e columns 42
datout(r, 79 - 42) = datout(r, 48 - 42) * datout(r, 49 - 42) * datout(r, 50 - 42) * datout(r, 51 - 42) * datout(r, 52 - 42) * datout(r, 53 - 42) * datout(r, 54 - 42) * datout(r, 55 - 42) * datout(r, 56 - 42) * datout(r, 57 - 42) * datout(r, 58 - 42) * datout(r, 59 - 42) * datout(r, 60 - 42) * datout(r, 61 - 42) * datout(r, 62 - 42) * datout(r, 63 - 42) * datout(r, 64 - 42) * datout(r, 65 - 42) * datout(r, 66 - 42) * datout(r, 67 - 42) * datout(r, 68 - 42) * datout(r, 69 - 42) * datout(r, 70 - 42) * datout(r, 71 - 42) * datout(r, 72 - 42) * datout(r, 73 - 42) * datout(r, 74 - 42) * datout(r, 75 - 42) * datout(r, 76 - 42)
testexp(r, 1) = (231859.13 * datout(r, 78 - 42) * datout(r, 79 - 42) * squrts(r, 1)) ' this line is always going to be zero because there is nothing in column 78
testexp(r, 2) = testexp(r, 1) / datr(r, 35)
Next r

.Range("Aq1:ca1226") = datout
.Range("An1:ao1226") = testexp

End With
ts2 = Timer()
MsgBox 1000 * (ts2 - ts1) & "milliseconds"
'Range(Cells(1, 1), Cells(10, UBound(barray))) = outr
End Sub

 

[offthelip]

Looking at your orginal statement, you said you wanted the users to be able to "play" with the weights to see what effect it had on the valuation. presumably this means altering values in the columns of one of the rows on the data sheet. (Not the baseline weights sheet) If this is the case, then this could be achieved by loading the dictionary of baseline weights once when the data sheet is activating and storing it in memory, then only recalculating the row which is being altered. This would be very fast which means it could be triggered from the worksheet change event and make the workhseet look just like a normal worksheet.

 

[spanishnick]

Hi @offthelip,

Thank you so much for your help. The codes you have suggested work perfectly! Your last suggestion of only recalculating the row which has been altered would be ideal, but I fear my limited knowledge in VBA would not allow me to get me there. The current code takes about 15 seconds, which is already significantly faster than 5 minutes previously!

There are two last things left for me to do which I was unfortunately not able to solve:
1) Generate the quintile groups in column AT of the "Data2" sheet (in the November 11 post), that is, after property values have been estimated, to assign a quintile group (1 for the 20% lowest valued properties, 2 for 20-40%, 3 for 40-60%, 4 for 60-80% and 5 for the 20% highest valued properties). I tried using the quinti
2) I now have two vba codes that I'd like to combine into a single code (each code works with different sheets: sheet "Data" and "Geomapping Data". However, when combining them and changing some of the variable names for the "Data" sheet (second half of the code), I then get different property values (product of columns) than I would when running it separately (which then gives the correct result). See below the two separate codes and the combined code which yields the wrong result.

Thank you again for all your help, very much appreciated!!

* Code for "Data" sheet

Sub test()
ts1 = Timer()
Dim Ary As Variant
Dim i As Long
Dim Dic As Object

Set Dic = CreateObject("Scripting.dictionary")
Dim outr()
barray = Array("A2", "F2", "G2", "H2", "I2", "J2", "K2", "L2", "M2", "N2", "O2", "P2", "Q2", "R2", "S2", "T2", "U2", "V2", "W2", "X2", "Y2", "Z2", "AA2", "AB2", "AC2", "AD2", "AE2", "AF2", "AG2", "AH2")
' first convert the column letters in barray to column numbers
ReDim outr(1 To 1226, 1 To UBound(barray) + 1)
For i = 0 To UBound(barray)
tt = Len(barray(i))
If tt = 2 Then
outr(2, i + 1) = Asc(Left(barray(i), 1)) - 64 ' column Number
outr(1, i + 1) = barray(i) ' Column Letter
Else
outr(2, i + 1) = Asc(Mid(barray(i), 2, 1)) - 64 + 26
outr(1, i + 1) = barray(i)
End If
Next i
''''''''''''''''''''''''''''
With Sheets("Baseline Weights")
Ary = .Range("b5:F167") ' load all the bae line weights into a variant array
For i = 1 To UBound(Ary)
Dic(Ary(i, 1)) = Ary(i, 5) ' add them all to the dictionary
Next i
End With
''''''''''''''''''''''''''''''
With Sheets("Data")
datr = .Range("A1:Am1226") ' load all the data into a variant array
End With
With Sheets("Data")
.Range("Aq1:Ca1226") = "" ' expand to column Ca (79)
datout = .Range("Aq1:Ca1226") ' load all the data into a variant array

For j = 1 To UBound(barray) + 1 ' loop through all the columns
head = datr(1, outr(2, j)) ' pick up header from row 1
datout(1, outr(2, j)) = head
For k = 2 To UBound(datr, 1) ' loop through all the rows
ditem = head & datr(k, outr(2, j))
If Dic.Exists(ditem) Then
datout(k, outr(2, j)) = Dic(ditem) + 1
Else
datout(k, outr(2, j)) = 1
End If
Next k
Next j
' .Range("Aq1:bx1226") = datout
' load the square roots from column CB
squrts = .Range("cb1:cb1226")
testexp = .Range("An1:ao1226")
' Aq is column 42
For r = 2 To 1226
' Note I have to change the addressing here because the variant array datout starts at column Aq i.e columns 42
datout(r, 79 - 42) = datout(r, 43 - 42) * datout(r, 48 - 42) * datout(r, 49 - 42) * datout(r, 50 - 42) * datout(r, 51 - 42) * datout(r, 52 - 42) * datout(r, 53 - 42) * datout(r, 54 - 42) * datout(r, 55 - 42) * datout(r, 56 - 42) * datout(r, 57 - 42) * datout(r, 58 - 42) * datout(r, 59 - 42) * datout(r, 60 - 42) * datout(r, 61 - 42) * datout(r, 62 - 42) * datout(r, 63 - 42) * datout(r, 64 - 42) * datout(r, 65 - 42) * datout(r, 66 - 42) * datout(r, 67 - 42) * datout(r, 68 - 42) * datout(r, 69 - 42) * datout(r, 70 - 42) * datout(r, 71 - 42) * datout(r, 72 - 42) * datout(r, 73 - 42) * datout(r, 74 - 42) * datout(r, 75 - 42) * datout(r, 76 - 42)
testexp(r, 1) = (231859.13 * datout(r, 79 - 42) * squrts(r, 1))
testexp(r, 2) = testexp(r, 1) / datr(r, 35)
Next r

.Range("Aq1:ca1226") = datout
.Range("An1:ao1226") = testexp

End With

Worksheets("Baseline Weights").Range("n19") = Application.WorksheetFunction.RSq(Sheets("Data").Columns("AN:AN"), Sheets("Data").Columns("AI:AI"))


ts2 = Timer()
MsgBox 1000 * (ts2 - ts1) & "milliseconds"
'Range(Cells(1, 1), Cells(10, UBound(barray))) = outr
End Sub

* Code for "Geomapping Data"

Sub test()
ts1 = Timer()
Dim Ary As Variant
Dim i As Long
Dim Dic As Object

Set Dic = CreateObject("Scripting.dictionary")
Dim outr()
barray = Array("A2", "B2", "C2", "D2", "E2", "F2", "G2", "H2", "I2", "J2", "K2", "L2", "M2", "N2", "O2", "P2", "Q2", "R2", "S2", "T2", "U2", "V2", "W2", "X2", "Y2", "Z2", "AA2", "AB2", "AC2", "AD2", "AE2", "AF2")
' first convert the column letters in barray to column numbers
ReDim outr(1 To 102835, 1 To UBound(barray) + 1)
For i = 0 To UBound(barray)
tt = Len(barray(i))
If tt = 2 Then
outr(2, i + 1) = Asc(Left(barray(i), 1)) - 64 ' column Number
outr(1, i + 1) = barray(i) ' Column Letter
Else
outr(2, i + 1) = Asc(Mid(barray(i), 2, 1)) - 64 + 26
outr(1, i + 1) = barray(i)
End If
Next i
''''''''''''''''''''''''''''
With Sheets("Baseline Weights")
Ary = .Range("b5:F167") ' load all the bae line weights into a variant array
For i = 1 To UBound(Ary)
Dic(Ary(i, 1)) = Ary(i, 5) ' add them all to the dictionary
Next i
End With
''''''''''''''''''''''''''''''
With Sheets("Geomapping Data")
datr = .Range("A1:At102835") ' load all the data into a variant array
End With
With Sheets("Geomapping Data")
.Range("ba1:Ct102835") = "" ' expand to column Ca (79)
datout = .Range("ba1:Ct102835") ' load all the data into a variant array

For j = 1 To UBound(barray) + 1 ' loop through all the columns
head = datr(1, outr(2, j)) ' pick up header from row 1
datout(1, outr(2, j)) = head
For k = 2 To UBound(datr, 1) ' loop through all the rows
ditem = head & datr(k, outr(2, j))
If Dic.Exists(ditem) Then
datout(k, outr(2, j)) = Dic(ditem) + 1
Else
datout(k, outr(2, j)) = 1
End If
Next k
Next j
' .Range("ba1:Ct102835") = datout
' load the square roots from column CB
commsqurts = .Range("da1:da102835")
domsqurts = .Range("db1:db102835")
instsqurts = .Range("dc1:dc102835")

commtestexp = .Range("Al1:al102835")
domtestexp = .Range("An1:an102835")
insttestexp = .Range("Ap1:ap102835")
testexp = .Range("As1:as102835")

' Ba is column 53
For r = 2 To 102835
' Note I have to change the addressing here because the variant array datout starts at column Aq i.e columns 42
datout(r, 99 - 53) = datout(r, 54 - 53) * datout(r, 57 - 53) * datout(r, 58 - 53) * datout(r, 59 - 53) * datout(r, 60 - 53) * datout(r, 61 - 53) * datout(r, 62 - 53) * datout(r, 63 - 53) * datout(r, 64 - 53) * datout(r, 65 - 53) * datout(r, 66 - 53) * datout(r, 67 - 53) * datout(r, 68 - 53) * datout(r, 69 - 53) * datout(r, 70 - 53) * datout(r, 71 - 53) * datout(r, 72 - 53) * datout(r, 73 - 53) * datout(r, 74 - 53) * datout(r, 75 - 53) * datout(r, 76 - 53) * datout(r, 77 - 53) * datout(r, 78 - 53) * datout(r, 79 - 53) * datout(r, 80 - 53) * datout(r, 81 - 53) * datout(r, 82 - 53) * datout(r, 83 - 53) * datout(r, 84 - 53) * datout(r, 85 - 53)
commtestexp(r, 1) = (231859.13 * datout(r, 99 - 53) * datout(r, 55 - 53) * commsqurts(r, 1))
domtestexp(r, 1) = (231859.13 * datout(r, 99 - 53) * domsqurts(r, 1))
insttestexp(r, 1) = (231859.13 * datout(r, 99 - 53) * datout(r, 56 - 53) * instsqurts(r, 1))
testexp(r, 1) = (commtestexp(r, 1) + domtestexp(r, 1) + insttestexp(r, 1))

Next r

.Range("ba1:Ct102835") = datout
.Range("Al1:al102835") = commtestexp
.Range("An1:an102835") = domtestexp
.Range("Ap1:ap102835") = insttestexp
.Range("As1:as102835") = testexp

End With



' Table of differences
Worksheets("Baseline Weights").Range("n7") = Application.Sum(Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n15") = Application.Sum(Sheets("Geomapping Data").Columns("AL:AL"))
Worksheets("Baseline Weights").Range("n16") = Application.Sum(Sheets("Geomapping Data").Columns("AN:AN"))
Worksheets("Baseline Weights").Range("n17") = Application.Sum(Sheets("Geomapping Data").Columns("AP:AP"))

Worksheets("Baseline Weights").Range("n9") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 1, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n10") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 2, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n11") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 3, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n12") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 4, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n13") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 5, Sheets("Geomapping Data").Columns("AS:AS"))


ts2 = Timer()
MsgBox 1000 * (ts2 - ts1) & "milliseconds"
'Range(Cells(1, 1), Cells(10, UBound(barray))) = outr
End Sub

* Combined code

Sub test()
ts1 = Timer()
Dim Ary As Variant
Dim i As Long
Dim Dic As Object

Set Dic = CreateObject("Scripting.dictionary")
Dim outr()
barray = Array("A2", "B2", "C2", "D2", "E2", "F2", "G2", "H2", "I2", "J2", "K2", "L2", "M2", "N2", "O2", "P2", "Q2", "R2", "S2", "T2", "U2", "V2", "W2", "X2", "Y2", "Z2", "AA2", "AB2", "AC2", "AD2", "AE2", "AF2")
' first convert the column letters in barray to column numbers
ReDim outr(1 To 102835, 1 To UBound(barray) + 1)
For i = 0 To UBound(barray)
tt = Len(barray(i))
If tt = 2 Then
outr(2, i + 1) = Asc(Left(barray(i), 1)) - 64 ' column Number
outr(1, i + 1) = barray(i) ' Column Letter
Else
outr(2, i + 1) = Asc(Mid(barray(i), 2, 1)) - 64 + 26
outr(1, i + 1) = barray(i)
End If
Next i
''''''''''''''''''''''''''''
With Sheets("Baseline Weights")
Ary = .Range("b5:F167") ' load all the bae line weights into a variant array
For i = 1 To UBound(Ary)
Dic(Ary(i, 1)) = Ary(i, 5) ' add them all to the dictionary
Next i
End With
''''''''''''''''''''''''''''''
With Sheets("Geomapping Data")
datr = .Range("A1:At102835") ' load all the data into a variant array
End With
With Sheets("Geomapping Data")
.Range("ba1:Ct102835") = "" ' expand to column Ca (79)
datout = .Range("ba1:Ct102835") ' load all the data into a variant array

For j = 1 To UBound(barray) + 1 ' loop through all the columns
head = datr(1, outr(2, j)) ' pick up header from row 1
datout(1, outr(2, j)) = head
For k = 2 To UBound(datr, 1) ' loop through all the rows
ditem = head & datr(k, outr(2, j))
If Dic.Exists(ditem) Then
datout(k, outr(2, j)) = Dic(ditem) + 1
Else
datout(k, outr(2, j)) = 1
End If
Next k
Next j
' .Range("ba1:Ct102835") = datout
' load the square roots from column CB
commsqurts = .Range("da1:da102835")
domsqurts = .Range("db1:db102835")
instsqurts = .Range("dc1:dc102835")

commtestexp = .Range("Al1:al102835")
domtestexp = .Range("An1:an102835")
insttestexp = .Range("Ap1:ap102835")
testexp = .Range("As1:as102835")

' Ba is column 53
For r = 2 To 102835
' Note I have to change the addressing here because the variant array datout starts at column Aq i.e columns 42
datout(r, 99 - 53) = datout(r, 54 - 53) * datout(r, 57 - 53) * datout(r, 58 - 53) * datout(r, 59 - 53) * datout(r, 60 - 53) * datout(r, 61 - 53) * datout(r, 62 - 53) * datout(r, 63 - 53) * datout(r, 64 - 53) * datout(r, 65 - 53) * datout(r, 66 - 53) * datout(r, 67 - 53) * datout(r, 68 - 53) * datout(r, 69 - 53) * datout(r, 70 - 53) * datout(r, 71 - 53) * datout(r, 72 - 53) * datout(r, 73 - 53) * datout(r, 74 - 53) * datout(r, 75 - 53) * datout(r, 76 - 53) * datout(r, 77 - 53) * datout(r, 78 - 53) * datout(r, 79 - 53) * datout(r, 80 - 53) * datout(r, 81 - 53) * datout(r, 82 - 53) * datout(r, 83 - 53) * datout(r, 84 - 53) * datout(r, 85 - 53)
commtestexp(r, 1) = (231859.13 * datout(r, 99 - 53) * datout(r, 55 - 53) * commsqurts(r, 1))
domtestexp(r, 1) = (231859.13 * datout(r, 99 - 53) * domsqurts(r, 1))
insttestexp(r, 1) = (231859.13 * datout(r, 99 - 53) * datout(r, 56 - 53) * instsqurts(r, 1))
testexp(r, 1) = (commtestexp(r, 1) + domtestexp(r, 1) + insttestexp(r, 1))

Next r

.Range("ba1:Ct102835") = datout
.Range("Al1:al102835") = commtestexp
.Range("An1:an102835") = domtestexp
.Range("Ap1:ap102835") = insttestexp
.Range("As1:as102835") = testexp

End With



' Table of differences
Worksheets("Baseline Weights").Range("n7") = Application.Sum(Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n15") = Application.Sum(Sheets("Geomapping Data").Columns("AL:AL"))
Worksheets("Baseline Weights").Range("n16") = Application.Sum(Sheets("Geomapping Data").Columns("AN:AN"))
Worksheets("Baseline Weights").Range("n17") = Application.Sum(Sheets("Geomapping Data").Columns("AP:AP"))

Worksheets("Baseline Weights").Range("n9") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 1, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n10") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 2, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n11") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 3, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n12") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 4, Sheets("Geomapping Data").Columns("AS:AS"))
Worksheets("Baseline Weights").Range("n13") = Application.WorksheetFunction.SumIf(Sheets("Geomapping Data").Columns("AT:AT"), 5, Sheets("Geomapping Data").Columns("AS:AS"))

Worksheets("Baseline Weights").Range("n19") = Application.WorksheetFunction.RSq(Sheets("Data").Columns("AN:AN"), Sheets("Data").Columns("AI:AI"))

' Data for accuracy
Dim Ary2 As Variant
Dim i2 As Long
Dim Dic2 As Object

Set Dic2 = CreateObject("Scripting.dictionary")
Dim outr2()
barray = Array("A2", "F2", "G2", "H2", "I2", "J2", "K2", "L2", "M2", "N2", "O2", "P2", "Q2", "R2", "S2", "T2", "U2", "V2", "W2", "X2", "Y2", "Z2", "AA2", "AB2", "AC2", "AD2", "AE2", "AF2", "AG2", "AH2")
' first convert the column letters in barray to column numbers
ReDim outr2(1 To 1226, 1 To UBound(barray) + 1)
For i2 = 0 To UBound(barray)
tt = Len(barray(i2))
If tt = 2 Then
outr2(2, i2 + 1) = Asc(Left(barray(i2), 1)) - 64 ' column Number
outr2(1, i2 + 1) = barray(i2) ' Column Letter
Else
outr2(2, i2 + 1) = Asc(Mid(barray(i2), 2, 1)) - 64 + 26
outr2(1, i2 + 1) = barray(i2)
End If
Next i2
''''''''''''''''''''''''''''
With Sheets("Baseline Weights")
Ary2 = .Range("b5:F167") ' load all the bae line weights into a variant array
For i2 = 1 To UBound(Ary2)
Dic(Ary2(i2, 1)) = Ary2(i2, 5) ' add them all to the dictionary
Next i2
End With
''''''''''''''''''''''''''''''
With Sheets("Data")
datr = .Range("A1:Am1226") ' load all the data into a variant array
End With
With Sheets("Data")
.Range("Aq1:Ca1226") = "" ' expand to column Ca (79)
datout = .Range("Aq1:Ca1226") ' load all the data into a variant array

For j = 1 To UBound(barray) + 1 ' loop through all the columns
head = datr(1, outr(2, j)) ' pick up header from row 1
datout(1, outr2(2, j)) = head
For k = 2 To UBound(datr, 1) ' loop through all the rows
ditem = head & datr(k, outr(2, j))
If Dic2.Exists(ditem) Then
datout(k, outr2(2, j)) = Dic2(ditem) + 1
Else
datout(k, outr2(2, j)) = 1
End If
Next k
Next j
' .Range("Aq1:bx1226") = datout
' load the square roots from column CB
squrts = .Range("cb1:cb1226")
testexp = .Range("An1:ao1226")
' Aq is column 42
For r = 2 To 1226
' Note I have to change the addressing here because the variant array datout starts at column Aq i.e columns 42
datout(r, 79 - 42) = datout(r, 43 - 42) * datout(r, 48 - 42) * datout(r, 49 - 42) * datout(r, 50 - 42) * datout(r, 51 - 42) * datout(r, 52 - 42) * datout(r, 53 - 42) * datout(r, 54 - 42) * datout(r, 55 - 42) * datout(r, 56 - 42) * datout(r, 57 - 42) * datout(r, 58 - 42) * datout(r, 59 - 42) * datout(r, 60 - 42) * datout(r, 61 - 42) * datout(r, 62 - 42) * datout(r, 63 - 42) * datout(r, 64 - 42) * datout(r, 65 - 42) * datout(r, 66 - 42) * datout(r, 67 - 42) * datout(r, 68 - 42) * datout(r, 69 - 42) * datout(r, 70 - 42) * datout(r, 71 - 42) * datout(r, 72 - 42) * datout(r, 73 - 42) * datout(r, 74 - 42) * datout(r, 75 - 42) * datout(r, 76 - 42)
testexp(r, 1) = (231859.13 * datout(r, 79 - 42) * squrts(r, 1))
testexp(r, 2) = testexp(r, 1) / datr(r, 35)
Next r

.Range("Aq1:ca1226") = datout
.Range("An1:ao1226") = testexp

End With

Worksheets("Baseline Weights").Range("n19") = Application.WorksheetFunction.RSq(Sheets("Data").Columns("AN:AN"), Sheets("Data").Columns("AI:AI"))

ts2 = Timer()
MsgBox 1000 * (ts2 - ts1) & "milliseconds"
'Range(Cells(1, 1), Cells(10, UBound(barray))) = outr
End Sub

 

[offthelip]

I now have two vba codes that I'd like to combine into a single code

My immediate reaction is WHY?? It would seem to me to be much better to leave them as two separate subroutines and to create a master subroutine that calls them in turn:

Sub master()
Call Datasub      ' change to whatever the name is
Call Geomappingsub ' ditto
End Sub

This is much better way of doing things, because it allows you make code changes that will affect one worksheet while absolutely assured it won't affect the other. also It opens up the possiblities that you can make the workbook more useable by only running the code that is necessary for that sheet and thus halving the runtime.
Finally since you are now using the dictionary in two separate places it makes much more sense now to only load it once. This will make the running the matching code a bit faster. This is actually quite easy to do . But first you must answer the question :
Do you ever change the baseline weights, and if so are you happy to save the workbook and reopen it before using is. or are you prepared to run a separate subrouinte "recalculate basline weights" ??
I am thinking of you having three sub, 1: load baseline weight, 2: calcualte datasub, 3: calcualte geomapping sub

 

[offthelip]

1) Generate the quintile groups in column AT of the "Data2" sheet (in the November 11 post),

I have been playing with equations to do this and I came up with this which seems a bit messy . you might do best to generate another question for that.:

=1*AND(G2>PERCENTILE(G$2:G$46,0),G2<PERCENTILE(G$2:G$46,0.2))+2*AND(G2>PERCENTILE(G$2:G$46,0.2),G2<PERCENTILE(G$2:G$46,0.4))+3*AND(G2>PERCENTILE(G$2:G$46,0.4),G2<PERCENTILE(G$2:G$46,0.6))+4*AND(G2>PERCENTILE(G$2:G$46,0.6),G2<PERCENTILE(G$2:G$46,0.8))+5*AND(G2>PERCENTILE(G$2:G$46,0.8),G2<PERCENTILE(G$2:G$46,1))

 

[spanishnick]

Thank you so much @offthelip , with the master file, it's much easier indeed. I've also removed the duplicate dictionary, it now takes less than 10 seconds to run. However, if I used the excel formula you suggested to generate the quintiles, it goes back to taking a few minutes. I've posted a potential code but it does not seem to work. Hopefully someone will know what to do.

Thank you again for all your help.