Return to Answer

• 1

• 2.2k
• 10
• 15

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: http://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.