Lookup by Comparing Multiple Columns (Array Loop)
Intro
- Although I would agree with most of Pavlo Slavynskyy's points (the screen updating is kind of debatable since you're using the fast
'copy-by-assignment method' i.e.
dCell.Value = sCell.Value, but it's good to know about it; and I have almost never used VLookup since there is the less restricting, brilliant Application.Match), you have made a crucial mistake with the loops. But let's keep it slow.
The Workbook
Your worksheets are not qualified i.e. they 'point' ('belong') to the ActiveWorkbook which could be any workbook.
Try the following experiment:
- In
Excel, open your workbook.
- Open a new workbook.
- Go to the
Visual Basic Editor and run your code.
- It will try to find the worksheets in the new workbook and probably raise
Run-time error '9': Subscript out of range.
In VBA, to reference the workbook containing this code, you use ThisWorkbook:
Dim wb As Workbook: Set wb = ThisWorkbook
Since you're dealing with just one workbook, wb is just fine. No need for additional characters.
The Worksheets
- First of all, I love
ws but only if there is only one worksheet. Using ws and ws2 is kind of confusing, which is which? Where am I reading from and where am I writing to?
- I've adopted a
Source-Destination concept, so I will use sws for the source and dws for the destination worksheets. You can create your own concept but you should be consistent about it.
- From the line
ws2.Cells(j, 120).Value = ws.Cells(j, 18).Value it is obvious that ws2 is you r Destination worksheet (dws) and ws is your Source worksheet (sws).
Efficiency: If Statement
If you write an If statement in one line e.g. ...
If A = 0 And B = 0 And C = 0 Then
... you have shortened the code, but on each loop, the code evaluates all three expressions, even if already A or B is not 0. For this simple example, there will be no practical difference in the efficiency but keep it in mind when you'll have more complex expressions.
Efficiency: The Mistake
To make the code more efficient, you want to access (read from, especially write to) the worksheets as few times as possible, but your loops do the opposite.
Firstly, you don't want to first loop through the rows in the columns of the source worksheet because you are trying to write to ('to fill') the cells of the destination worksheet.
Secondly, now when you loop through the rows in the columns of the destination worksheet when a value (in this case 3 values are matched) is found, you don't need to loop any longer (it's found), so use Exit For:
If Something Then ' e.g. value found
Do Whatever
Exit For ' stop looping
End If
... to exit the loop.
The Split Function
When you have a list in a string, e.g.,...
Dim sNamesList As String: sNamesList = "John,Peter,Mary"
... you can easily write the values to an array using the Split function ...
Dim sNames() As String: sNames = Split(sNamesList, ",")
... but be careful, any spaces inside will not be truncated.
The resulting array is always a (1D) zero-based array.
Efficiency: Using Arrays
By introducing arrays into your code, you will reduce accessing the worksheets to the minimum.
You can read each range into an array (in one go) as simple as:
Dim rg As Range: Set rg = Range("A1:A10")
Dim Data As Variant: Data = rg.Value
In this case, the expression rg.Value alone is (has created) already a 2D one-based array with ten rows and one column containing the values of the range.
Note that this is not true if the range contains only one cell (see the GetRange function for details).
Knowing this, you can now loop through the elements of the arrays (in memory) instead of the cells of the worksheet and vastly improve the performance of the code.
Similarly, you can write the values of a 2D one-based array to the worksheet in one go:
Dim rg As Range: rg.Resize(Ubound(Data, 1), Ubound(Data, 2)).Value = Data
... or in our case, since there is only one column per 2D array, you can simplify:
Dim rg As Range: rg.Resize(Ubound(Data, 1)).Value = Data
Readability
- To make the code more readable you can create your helper procedures which you may use in some other projects, e.g.
RefColumn and GetRange.
Miscellaneous
- The code is written according to your posted code.
- To use it in your provided sample file, change the following:
"Sheet3" to "Sheet2""R" to "Q""Sheet2" to "Sheet1"
The Main Code
Option Explicit
Sub LookupMultiColumnsCompare()
Const ProcTitle As String = "Lookup Multi Columns Compare"
' Source
Const sName As String = "Sheet3"
Const sFirst As String = "N3"
Const scColsList As String = "N,O,P" ' 14, 15, 16 add more (or less)
Const svCol As String = "R" ' 18
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "CT3"
Const dcColsList As String = "CT,CY,DJ" ' 98, 103, 114 ' add more
' *** Triple-check the following because in this column the data
' will be overwritten! Remember, there is no undo.
Const dvCol As String = "DP" ' 120
' Create a reference to the workbook containing this code ('ThisWorkbook').
Dim wb As Workbook: Set wb = ThisWorkbook
Dim WasSuccessful As Boolean
Dim n As Long ' Compare Columns Arrays Counter (Source, Destination, Loop)
On Error GoTo ClearError
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
Dim srg As Range: Set srg = RefColumn(sfCell)
If srg Is Nothing Then Exit Sub ' no data
Dim srCount As Long: srCount = srg.Rows.Count
Dim scCols() As String: scCols = Split(scColsList, ",")
Dim nUpper As Long: nUpper = UBound(scCols)
Dim sData As Variant: ReDim sData(0 To nUpper)
For n = 0 To nUpper
sData(n) = GetRange(srg.EntireRow.Columns(scCols(n)))
Next n
Dim svData As Variant: svData = GetRange(srg.EntireRow.Columns(svCol))
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim drg As Range: Set drg = RefColumn(dfCell)
If drg Is Nothing Then Exit Sub ' no data
Dim drCount As Long: drCount = drg.Rows.Count
Dim dcCols() As String: dcCols = Split(dcColsList, ",")
Dim dData As Variant: ReDim dData(0 To nUpper)
For n = 0 To nUpper
dData(n) = GetRange(drg.EntireRow.Columns(dcCols(n)))
Next n
Dim dvData As Variant: ReDim dvData(1 To drCount, 1 To 1)
' You could speed up the code if the values will always stay the same
' once they are written i.e. if you already have found the matches
' the first time and you don't need to modify them, by rather reading
' the 'Value' column range into the array.
' Instead of the previous line use the following...
'Dim dvData As Variant: dvData = GetRange(drg.EntireRow.Columns(dvCol))
' ... and test the value of each item in the array before looping further
' by adding a new 'If' statement below the line 'For dr = 1 To drCount':
' 'If Len(dvData(dr, 1)) = 0 Then"'. Don't forget about its 'End If'.
' Loop
Dim sValue As Variant
Dim sr As Long
Dim dCell As Range
Dim dValue As Variant
Dim dr As Long
For dr = 1 To drCount
For sr = 1 To srCount
For n = 0 To nUpper
dValue = dData(n)(dr, 1)
' Dependent on your data, some of the following 'If' statements
' may be redundant but they should slow down the code,
' so think twice before removing (uncommenting) them.
If IsError(dValue) Then Exit For ' exclude error values
If Len(dValue) = 0 Then Exit For ' exclude blanks
sValue = sData(n)(sr, 1)
If IsError(sValue) Then Exit For ' exclude error values
If IsDate(sValue) Then
If IsDate(dValue) Then
' The tricky date part when it contains time.
If Round(CDbl(sValue), 6) <> Round(CDbl(sValue), 6) Then
Exit For
End If
End If
Else
If sValue <> dValue Then Exit For
End If
Next n
' Note that if the loop was not interrupted, 'n = nUpper + 1'.
If n > nUpper Then
dvData(dr, 1) = svData(sr, 1)
End If
Next sr
Next dr
' Overwrite the values in destination with values in the array.
Dim dvrg As Range: Set dvrg = drg.EntireRow.Columns(dvCol)
dvrg.Value = dvData
WasSuccessful = True
InfoExit:
If WasSuccessful Then
MsgBox "Worksheet successfully updated.", _
vbInformation, ProcTitle
Else
MsgBox "Something went wrong." & vbLf _
& "Double-check the values in the constants section of the code.", _
vbCritical, ProcTitle
End If
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume InfoExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
Some Toys
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the Excel column string from a (column) number.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnString( _
ByVal ColumnNumber As Long) _
As String ' only '-2147483648#' crashes it!?
Dim Remainder As Long
Do
Remainder = (ColumnNumber - 1) Mod 26
GetColumnString = Chr(Remainder + 65) & GetColumnString
ColumnNumber = Int((ColumnNumber - Remainder) \ 26)
Loop Until ColumnNumber = 0
End Function
Sub GetColumnStringTEST()
Debug.Print GetColumnString(120)
Debug.Print GetColumnString(16384) ' max for 'Excel'
Debug.Print GetColumnString(2147483647) ' max for 'Long'
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the Excel column number from a (column) string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnNumber( _
ByVal ColumnString As String) _
As Long
On Error GoTo ClearError ' too many chars: "Run-time error '6': Overflow"
Dim ColumnStringLength As Long: ColumnStringLength = Len(ColumnString)
Dim n As Long
Dim CharNumber As Long
Dim CharIndex As Long
Dim ColumnNumber As Long
For n = ColumnStringLength To 1 Step -1
CharNumber = Asc(UCase(Mid(ColumnString, n))) - 64
If CharNumber >= 1 Then
If CharNumber <= 26 Then
ColumnNumber = ColumnNumber + CharNumber * 26 ^ CharIndex
CharIndex = CharIndex + 1
End If
End If
Next
GetColumnNumber = ColumnNumber
ProcExit:
Exit Function
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Function
Sub GetColumnNumberTEST()
Debug.Print GetColumnNumber("DP")
Debug.Print GetColumnNumber("XFD") ' max for 'Excel'
Debug.Print GetColumnNumber("FXSHRXW") ' max for 'Long'
End Sub
