3
\$\begingroup\$

I am working on a script to write an array formula to a large number of cells. I have a code that works, but is very slow. Any thoughts on how to speed it up? The end goal is to be able to quickly write an array formula to several cells. The problem is that each cell has a unique formula. So I couldn't think of a way to simplify the code. Here is the code as it is written now:

Sub make_sheet()

Dim m As Integer
Dim h As Integer
Dim a As Integer
Dim b As Integer
Dim dt As String
Dim man As String


m = 10005
h = 2
a = 1
dt = ActiveWorkbook.Sheets("DCAM2_REVD-ODB-11-18-2016_2017-").Cells(2, 4).Value
man = InputBox("Who Manufactured the PCB?", "Manufacture")

ActiveWorkbook.Sheets("Sheet1").Cells(1, 6).FormulaR1C1 = "time/date stamp of test"
ActiveWorkbook.Sheets("Sheet1").Cells(1, 7).FormulaR1C1 = "Manufacturer"
ActiveWorkbook.Sheets("Sheet1").Cells(1, 12).FormulaR1C1 = "Channel"


For i = 2 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(i, 6).FormulaR1C1 = dt
Next i

For i = 2 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(i, 7).FormulaR1C1 = man
Next i

b = 0
For i = 2 To 11 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(i, 12).FormulaR1C1 = "DS0" & b & ""
b = b + 1
Next i

b = 10
For i = 12 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(i, 12).FormulaR1C1 = "DS" & b & ""
b = b + 1
Next i

For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(1, i).FormulaR1C1 = "A" & a & ""
a = a + 1
Next i

a = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(1, i).FormulaR1C1 = "P" & a & ""
a = a + 1
Next i

For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(2, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(2, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(2, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(2, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(3, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(3, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(3, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(3, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(4, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(4, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(4, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(4, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(5, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(5, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(5, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(5, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(6, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(6, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(6, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(6, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(7, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(7, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(7, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(7, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(8, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(8, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(8, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(8, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(9, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(9, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(9, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(9, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(10, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(10, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(10, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(10, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(11, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(11, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(11, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(11, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(12, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(12, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(12, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(12, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(13, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(13, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(13, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(13, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(14, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(14, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(14, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(14, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(15, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(15, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(15, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(15, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(16, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(16, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(16, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(16, i).NumberFormat = "0.00"
h = h + 1
Next i

m = m + 1000
h = 2
For i = 13 To 17 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(17, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_" & h & "_13_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(17, i).NumberFormat = "0.00"
h = h + 1
Next i

h = 1
For i = 18 To 29 Step 1
ActiveWorkbook.Sheets("Sheet1").Cells(17, i).FormulaArray = "=Product(0.03937,(VLOOKUP(""U" & m & """&""#_2_" & h & "_Hei"",CHOOSE({1,2},'DCAM2_REVD-ODB-11-18-2016_2017-'!B:B&'DCAM2_REVD-ODB-11-18-2016_2017-'!E:E,'DCAM2_REVD-ODB-11-18-2016_2017-'!H:H),2,0)))"
ActiveWorkbook.Sheets("Sheet1").Cells(17, i).NumberFormat = "0.00"
h = h + 1
Next i


End Sub
\$\endgroup\$
  • \$\begingroup\$ Is there a requirement for the formula results to change once you fill out the worksheet? If the data behind the VLOOKUP and Productformulas will change, then your array formulas may be a good choice. But if you're constructing the worksheet and results only once, then you'd get better VBA performance if you calculated all the results using a VBA function and insert the results directly (without worksheet formulas). \$\endgroup\$ – PeterT Mar 24 '17 at 14:41
  • \$\begingroup\$ @PeterT It is a one time update. I'm not that familiar with running array formulas in a VBA Function. Could you give me an example of how it would look? \$\endgroup\$ – Tim Eckmann Mar 24 '17 at 16:44
1
\$\begingroup\$

You have a good start on what you need to do because you've nailed down the loops and formulas you want to see in the end result. Bonus points goes to you for not using Select or Activate! Let's take your VBA to the next level.

First, help yourself out by creating interim values/objects that more accurately (and simply) reference your data. In this case Always define and set references to all Workbooks and Sheets:

Dim wb As Workbook
Dim sourceWS As Worksheet
Dim destWS As Worksheet
Dim man As String
Set wb = ActiveWorkbook
Set sourceWS = wb.Sheets("DCAM2_REVD-ODB-11-18-2016_2017-")
Set destWS = wb.Sheets("Sheet1")

Second, help yourself even more by establishing some constants to help identify fixed values, such as specific columns or limits. This is especially helpful if you ever need to change the value because you only need to change it in one place. Also, use meaningful names for variables so that you can more easily "read" your code without having to interpret it inside your head (such as the "source" and "destination" variables).

'--- column indexes
Const TIMESTAMP = 6
Const MFG = 7
Const CHAN = 12

'--- establish column headers
destWS.Cells(1, TIMESTAMP) = "time/date stamp of test"
destWS.Cells(1, MFG) = "Manufacturer"
destWS.Cells(1, CHAN) = "Channel"

Dim dateTime As Date
Dim mfgInput As String
dateTime = sourceWS.Cells(2, 4).Value
mfgInput = InputBox("Who Manufactured the PCB?", "Input Manufacturer")

Const MAX_CHANNELS = 16
Const MAX_A = 5
Const MAX_P = 12

Dim i As Long
For i = 2 To MAX_CHANNELS + 1
    destWS.Cells(i, TIMESTAMP) = Format(dateTime, "dd-mmm-yyyy")
    destWS.Cells(i, MFG) = mfgInput
    destWS.Cells(i, CHAN) = "DS" & Format(i - 2, "0#")
Next i

Third is a bit more advanced. It looks like each time you need a VLOOKUP formula, you're referring to the same set of values in three columns. This doesn't seem to change, so that data (and therefore the resulting calculation) is static -- which means you don't really need a formula. You can calculate the value right in the VBA and drop the result in the cell.

The VLOOKUP is using the nifty CHOOSEfunction to achieve a multi-variable vlookup. Very cool stuff, but you do it much quicker in VBA with a Dictionary in the VBA (rather than on the worksheet).

You are concatenating values in Columns B and E to select a value in Column H. So to get the resulting Dictionary, I'm doing two things: a) moving those columns into a memory array (for speed), and b) building a Dictionary with keys.

Dim lookupRange As Range
Set lookupRange = Application.Union(destWS.Range("B1:B1000"), _
                                    destWS.Range("e1:e1000"), _
                                    destWS.Range("h1:h1000"))
'--- create a Dictionary of all the lookup data
Dim dataDict As Dictionary
Set dataDict = LookupDictionary(lookupRange)

Because your columns are NOT contiguous (next to each other), I'm using a nifty function from @TimWilliams (found here). Then creating the Dictionary by combining the first two columns in the array (which come from columns B and E on the worksheet), into a single string Key for each row. The value on that row in column H is stored as the Dictionary.Item.

Function LookupDictionary(ByRef dataRange As Range) As Dictionary
    '--- the dataRange may be either a contiguous or non-contiguous area
    '    of cells. it will be transferred to a memory array first before
    '    translating into a Dictionary. all columns except the last column
    '    are concatenated into a single string Key for the Dictionary. the        
    '    value in the last column is stored as the Item value.
    Dim dataArray As Variant
    dataArray = ToArray(dataRange)
    Dim numRows As Long
    Dim numCols As Long
    numRows = UBound(dataArray, 1)
    numCols = UBound(dataArray, 2)

    Dim newDict As Dictionary
    Set newDict = New Dictionary

    Dim i As Long
    Dim j As Long
    For i = 1 To numRows
        Dim newKey As String
        newKey = ""
        For j = 1 To numCols - 1
            newKey = newKey & dataArray(i, j)
        Next j
        '--- each key must be unique, for duplicate keys
        '    only the first key,value is added
        If Not newDict.Exists(newKey) Then
            newDict.Add newKey, dataArray(i, numCols)
        End If
    Next i
    Set LookupDictionary = newDict
End Function

Finally, we get to the real meat of the program. You have many loops duplicated, basically doing the same thing to build up each row in your data set. I'm pretty sure that each row is nearly identical with only some values changing in each row (in the VLOOKUP parts). So what I've done here is to collapse all that into two loops. (I did the first one as an example, you can work the second loop.)

Dim target As String
Dim startCol As Long
Dim j As Long
startCol = 13
For i = 1 To MAX_A
    destWS.Cells(1, startCol + i - 1) = "A" & i  '--- column label
    For j = 1 To MAX_CHANNELS
        target = "U" & Format(10 + (j - 1), "##") & "005#_" & (i + 1) & "_13_Hei"
        '--- delete or comment this line after debugging...
        Debug.Print target
        destWS.Cells(j + 1, startCol + i - 1) = 0.03937 * dataDict.Item(target)
    Next j
Next i
startCol = startCol + MAX_A
For i = 1 To MAX_P
    destWS.Cells(1, startCol + i - 1) = "P" & i  '--- column label
    '--- build up this section just like the one above...
Next i

Those nested loops are adding both the column header and the values. Note that the first loop fills in the data for the A1-A5 data columns. You'll have to copy that code and work it for the P1-P12 columns.

So, as a single module, here is the complete code to start you with:

Option Explicit

Sub MakeSheet()
    Dim wb As Workbook
    Dim sourceWS As Worksheet
    Dim destWS As Worksheet
    Dim man As String
    Set wb = ActiveWorkbook
    Set sourceWS = wb.Sheets("DCAM2_REVD-ODB-11-18-2016_2017-")
    Set destWS = wb.Sheets("Sheet1")

    '--- column indexes
    Const TIMESTAMP = 6
    Const MFG = 7
    Const CHAN = 12

    '--- establish column headers
    destWS.Cells(1, TIMESTAMP) = "time/date stamp of test"
    destWS.Cells(1, MFG) = "Manufacturer"
    destWS.Cells(1, CHAN) = "Channel"

    Dim dateTime As Date
    Dim mfgInput As String
    dateTime = sourceWS.Cells(2, 4).Value
    mfgInput = InputBox("Who Manufactured the PCB?", "Input Manufacturer")

    Const MAX_CHANNELS = 16
    Const MAX_A = 5
    Const MAX_P = 12

    Dim i As Long
    For i = 2 To MAX_CHANNELS + 1
        destWS.Cells(i, TIMESTAMP) = Format(dateTime, "dd-mmm-yyyy")
        destWS.Cells(i, MFG) = mfgInput
        destWS.Cells(i, CHAN) = "DS" & Format(i - 2, "0#")
    Next i

    Dim lookupRange As Range
    Set lookupRange = Application.Union(destWS.Range("B1:B1000"), _
                                        destWS.Range("e1:e1000"), _
                                        destWS.Range("h1:h1000"))
    '--- create a Dictionary of all the lookup data
    Dim dataDict As Dictionary
    Set dataDict = LookupDictionary(lookupRange)

    Dim target As String
    Dim startCol As Long
    Dim j As Long
    startCol = 13
    For i = 1 To MAX_A
        destWS.Cells(1, startCol + i - 1) = "A" & i  '--- column label
        For j = 1 To MAX_CHANNELS
            target = "U" & Format(10 + (j - 1), "##") & "005#_" & (i + 1) & "_13_Hei"
            '--- delete or comment this line after debugging...
            Debug.Print target
            destWS.Cells(j + 1, startCol + i - 1) = 0.03937 * dataDict.Item(target)
        Next j
    Next i
    startCol = startCol + MAX_A
    For i = 1 To MAX_P
        destWS.Cells(1, startCol + i - 1) = "P" & i  '--- column label
        '--- build up this section just like the one above...
    Next i

    Set dataDict = Nothing
End Sub

Function LookupDictionary(ByRef dataRange As Range) As Dictionary
        '--- the dataRange may be either a contiguous or non-contiguous area
        '    of cells. it will be transferred to a memory array first before
        '    translating into a Dictionary. all columns except the last column
        '    are concatenated into a single string Key for the Dictionary. the
        '    value in the last column is stored as the Item value.
    Dim dataArray As Variant
    dataArray = ToArray(dataRange)
    Dim numRows As Long
    Dim numCols As Long
    numRows = UBound(dataArray, 1)
    numCols = UBound(dataArray, 2)

    Dim newDict As Dictionary
    Set newDict = New Dictionary

    Dim i As Long
    Dim j As Long
    For i = 1 To numRows
        Dim newKey As String
        newKey = ""
        For j = 1 To numCols - 1
            newKey = newKey & dataArray(i, j)
        Next j
        '--- each key must be unique, for duplicate keys
        '    only the first key,value is added
        If Not newDict.Exists(newKey) Then
            newDict.Add newKey, dataArray(i, numCols)
        End If
    Next i
    Set LookupDictionary = newDict
End Function

Function ToArray(rng) As Variant()
    '--- from: https://stackoverflow.com/a/18994211/4717755
    Dim arr() As Variant, r As Long, nr As Long
    Dim ar As Range, c As Range, cnum As Long, rnum As Long
    Dim col As Range

    nr = rng.Areas(1).Rows.Count
    ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
    cnum = 0
    For Each ar In rng.Areas
        For Each col In ar.Columns
            cnum = cnum + 1
            rnum = 1
            For Each c In col.Cells
                arr(rnum, cnum) = c.Value
                rnum = rnum + 1
            Next c
        Next col
    Next ar

    ToArray = arr
End Function

This runs VERY fast because all the processing is performed in memory with VBA and doesn't rely on formulas.

Last notes:

  1. When referring to the "values" of Cells, you shouldn't put string data in the .Formula bit. Just add it as the .Value. If you don't use the .Value property of the Cell, it is implied.
  2. Stay away from variable names like m, dt, or h. Use a more descriptive name (and you can even keep it short). It will definitely help in the long run.
\$\endgroup\$
  • \$\begingroup\$ I finally have had a chance to play around with this. I keep getting an error referring to the New Dictionary. It is saying "Invalid Use of New keyword." Any suggestions? \$\endgroup\$ – Tim Eckmann Mar 30 '17 at 13:19
  • \$\begingroup\$ You're possibly missing the reference to the proper library for early binding. In the VBA Editor menu, go to Tools> References> Microsoft Scripting Runtime and make sure it's checked and see if that helps. \$\endgroup\$ – PeterT Mar 30 '17 at 14:22
  • \$\begingroup\$ I verified that is checked. I also have an issue where the dataDict.Item errors out, unless I change the Dim dataDict As Dictionary to Dim dataDict As Scripting.Dictionary but then the code doesn't seem to work correctly. I am using Excel 2013. So I don't know if that is the issue. \$\endgroup\$ – Tim Eckmann Mar 30 '17 at 14:55
  • \$\begingroup\$ I'm also using Excel 2013 and it works fine. Can you review this reference and see if you can work some of the examples in test code? That might work out an issue and help to point out a difference in syntax or usage between your setup and mine. \$\endgroup\$ – PeterT Mar 30 '17 at 18:00
  • \$\begingroup\$ Peter, I was able to get it to work. There were 2 issues. First, I had to change all instances of the Dictionary to Scripting.Dictionary, then I found that for the lookupRange, you had it looking at the destination sheet instead of the source sheet. So I changed that and everything is working now. I also added in the number formatting for each cell after it is populated so it was only a 2 decimal number. Thank you again for all the help on this. Problem Solved. \$\endgroup\$ – Tim Eckmann Mar 30 '17 at 18:46
2
\$\begingroup\$

Every time you plug a formula into an Excel cell it causes the application to recalculate the new cell and any other cells that were affected indirectly. When you start updating hundreds of cells via macro, it starts to bog things down. This is especially true when formulas are intensive (ie, array formulas).

To circumvent this issue, you can temporarily turn off automatic calculation in Excel using the Application's Calculation property. Doing this will cause Excel to only recalculate once, after you've finished entering all the new formulas.

Try wrapping your code with the following:

Application.Calculation = xlCalculationManual

'CODE CODE CODE

Application.Calculation = xlCalculationAutomatic
Application.Calculate
\$\endgroup\$
  • \$\begingroup\$ Welcome to StackExchange Code Review! Please see: How do I write a good answer?, where you will find: "Every answer must make at least one insightful observation about the code in the question. Answers that merely provide an alternate solution with no explanation or justification do not constitute valid Code Review answers and may be deleted". \$\endgroup\$ – Stephen Rauch Mar 24 '17 at 0:07
  • \$\begingroup\$ Nicely done! Again, welcome. \$\endgroup\$ – Stephen Rauch Mar 24 '17 at 6:30
  • \$\begingroup\$ @Yoni thank you for the suggestion. I tried it out, but it didn't really improve the performance. \$\endgroup\$ – Tim Eckmann Mar 24 '17 at 12:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.