In my previous post Optimise compare and match method using scripting.dictionary in VBA I wanted to address optimising the scripting.dictionary approach I was using and I feel I have achieved that (feel free to correct me though!). I am now implementing user input boxes which have also increased the complexity and now have duplicated code. I'm wondering if there might be a better way of doing this?
This is all one sub procedure and it is working well as far as I have been able to test it, I have just broken it up with comments.
Public Sub arrayMatchv3()
Dim workingArray As Variant
Dim workingCell As Range
Dim workingLastRow As Long
Set workingCell = Application.InputBox("Select the first cell of your comparison column.", Type:=8)
workingLastRow = workingCell.End(xlDown).Row
With workingCell
workingArray = Range(.Address, Left(.Address, Len(.Address) - 1) & workingLastRow)
End With
Dim targetArray As Variant
Dim targetCell As Range
Set targetCell = Application.InputBox("Select the first cell of your target column.", Type:=8)
With targetCell
targetArray = Range(.Address, Left(.Address, Len(.Address) - 1) & workingLastRow)
End With
Dim i As Long
With the below ReDim section, I am unsure of any method to write a single column from the worksheet to a single column within a 2d array, so have resorted to looping to populate the second column. Perhaps it isn't really needed to add them both into a single array?
ReDim Preserve workingArray(1 To UBound(workingArray, 1), 1 To UBound(workingArray, 2) + 1)
For i = LBound(workingArray, 1) To UBound(workingArray, 1)
workingArray(i, UBound(workingArray, 2)) = targetArray(i, 1)
Next i
The below three code sections are duplicates of the three above but using different variables, not sure how to address this?
Dim comparisonArray As Variant
Dim comparisonCell As Range
Dim comparisonLastRow As Long
Set comparisonCell = Application.InputBox("Select the first cell of the column to match values with.", Type:=8)
comparisonLastRow = comparisonCell.End(xlDown).Row
With comparisonCell
comparisonArray = Range(.Address, Left(.Address, Len(.Address) - 1) & workingLastRow)
End With
Dim returnArray As Variant
Dim returnCell As Range
Set returnCell = Application.InputBox("Select the first cell from the column you wish to return values from.", Type:=8)
With returnCell
returnArray = Range(.Address, Left(.Address, Len(.Address) - 1) & comparisonLastRow)
End With
ReDim Preserve comparisonArray(1 To UBound(comparisonArray, 1), 1 To UBound(comparisonArray, 2) + 1)
For i = LBound(comparisonArray, 1) To UBound(comparisonArray, 1)
comparisonArray(i, UBound(comparisonArray, 2)) = returnArray(i, 1)
Next i
I'm quite happy with the remaining code which includes a lot of feedback from my previous posts, but critique is still welcome, especially if it can address any potential performance issues.
With New Scripting.Dictionary
.CompareMode = vbTextCompare
For i = LBound(comparisonArray, 1) To UBound(comparisonArray, 1)
If Not .Exists(comparisonArray(i, 1)) Then
.Add comparisonArray(i, 1), comparisonArray(i, 2)
End If
Next i
Dim arrayToPaste As Variant
ReDim arrayToPaste(1 To UBound(workingArray, 1), 1 To 1)
For i = LBound(workingArray, 1) To UBound(workingArray, 1)
If Len(workingArray(i, 2)) = 0 Then
If .Exists(workingArray(i, 1)) Then
arrayToPaste(i, 1) = .Item(workingArray(i, 1))
End If
Else
arrayToPaste(i, 1) = workingArray(i, 2)
End If
Next i
End With
With targetCell
Range(.Address, Left(.Address, Len(.Address) - 1) & workingLastRow) = arrayToPaste
End With
End Sub