I have two columns (A & B) of company names & cities. I have another two columns (D & E) of the same. If a certain row of A&B is not present in any row of D&E then I need to add that row of A&B to the end of columns D&E. So basically match and if no match then add. About 550 rows of data in A&B and 6000 in D&E. For loop takes 73 and StrComp 357 secs. This is just one file and I have a few thousand of these files. The StrComp is based on - In Excel 2010 compare data from columns and highlight values if different using macro and VBA. I tried the array method by mehow at Excel VBA fast compare method of 2 columns - its very fast - currently compares column A with column D and appends at the end of column D in 1 sec. Been struggling to modify it to do a 2-column (A&B) to 2-column (D&E) matching for quite some time...am I missing something fairly simple or is this too complex? Thanks much for any help... Code I am trying to modify -

```
Sub CompareAddArr()
Application.ScreenUpdating = False
Dim stNow As Date
stNow = Now
Dim arr As Variant
arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim varr As Variant
Set varr = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).Value
Dim x, y, match As Boolean
For Each x In arr
match = False
For Each y In varr
If x = y Then match = True 'this matches colA with colD - 1col-1col
'here need something like - if x = y and a = b Then match = True (for ColB with ColE)
Next y
If Not match Then
Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1) = x
'here need something like - Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1) = a
End If
Next
Application.ScreenUpdating = True
MsgBox DateDiff("s", stNow, Now)
End Sub
```

# Best How To :

To adapt this code, you should:

- Use a
`Worksheet`

variable. That way your code isn't bound to the `ActiveSheet`

- Get both columns of each range into your Variant Arrays
- Loop over the arrays, comparing both items in each row
- Exit the inner loop early when a match is found
- Accumulate data to copy into another Variant array (this avoid accessing the sheet for each result)
Copy the resulting new data in one go at the end of the loops

```
Sub CompareAddArr()
Dim arr As Variant
Dim varr As Variant
Dim x, y, match As Boolean
Dim i As Long, j As Long
Dim InsertRow As Long
Dim Newdata As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
With ws
arr = Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp)).Value
varr = Range(.Cells(2, 5), .Cells(.Rows.Count, 4).End(xlUp)).Value
InsertRow = 1
ReDim Newdata(1 To 2, 1 To UBound(arr, 1))
For i = 1 To UBound(arr, 1)
match = False
For j = 1 To UBound(varr, 1)
If arr(i, 1) = varr(j, 1) And arr(i, 2) = varr(j, 2) Then
match = True
Exit For
End If
Next
If Not match Then
Newdata(1, InsertRow) = arr(i, 1)
Newdata(2, InsertRow) = arr(i, 2)
InsertRow = InsertRow + 1
'Like LR = LR + 1, how can I increment UBound(varr, 1) by 1 here
End If
Next
If InsertRow > 1 Then
ReDim Preserve Newdata(1 To 2, 1 To InsertRow - 1)
.Range("D2:E2").Offset(UBound(varr, 1)).Resize(UBound(Newdata, 2), 2).Value = _
Application.Transpose(Newdata)
End If
End With
End Sub
```

**Update** - New requirement, add unique entries only once

To add a record from `arr`

only if it's not already added, test the `Newdata`

array and only if it's not already in that array, add it.

I've also added a parameter to specify how many columns to process and the corresponding code

```
Sub CompareAddArrUnique()
Dim arr As Variant
Dim varr As Variant
Dim match As Boolean
Dim i As Long, j As Long
Dim InsertRow As Long
Dim Newdata As Variant
Dim ws As Worksheet
Dim NumberOfColumns As Long
Dim col As Long
Set ws = ActiveSheet
NumberOfColumns = 2
With ws
arr = Range(.Cells(2, NumberOfColumns), .Cells(.Rows.Count, 1).End(xlUp)).Value
varr = Range(.Cells(2, 4 + NumberOfColumns - 1), .Cells(.Rows.Count, 4).End(xlUp)).Value
InsertRow = 1
ReDim Newdata(1 To NumberOfColumns, 1 To UBound(arr, 1))
For i = 1 To UBound(arr, 1)
match = False
For j = 1 To UBound(varr, 1) ' <---
match = True
For col = 1 To NumberOfColumns ' <---
match = match And (arr(i, col) = varr(j, col))
If Not match Then Exit For
Next
If match Then Exit For
Next
If Not match Then
For j = 1 To InsertRow - 1
match = True
For col = 1 To NumberOfColumns
match = match And (arr(i, col) = Newdata(col, j))
If Not match Then Exit For
Next
If match Then Exit For
Next
End If
If Not match Then
For j = 1 To NumberOfColumns
Newdata(j, InsertRow) = arr(i, j)
Next
InsertRow = InsertRow + 1
End If
Next
If InsertRow > 1 Then
ReDim Preserve Newdata(1 To 2, 1 To InsertRow - 1)
.Range("D2:E2").Offset(UBound(varr, 1)).Resize(UBound(Newdata, 2), 2).Value = _
Application.Transpose(Newdata)
End If
End With
End Sub
```