Excel VBA - Compare matching cell values in arrays and copy entire rows

[TropicalMagic]

Hi all,


I would like to compare cell values in column E of Workbook A’s worksheet 1 to those in column A of ReferenceList workbook’s worksheet 1.

Matching cell values will have their entire row be copied over to Workbook B’s worksheet 1, which will be empty at first.


I have placed the ranges into an array for speedier processing, since the number of rows can be in the 1000s.


The screenshots show mock-up samples:


Workbook A’s worksheet 1:

ReferenceList’s worksheet 1:

However, the code is not working:

Sub ACCEPTED_OCEAN_OTQ_CHECK()



Application.ScreenUpdating = False

Application.DisplayAlerts = False



Workbooks.Open ("WorkbookA.xlsx")

Workbooks.Open ("WorkbookB.xlsx")

Workbooks.Open ("ReferenceList")



Dim WorkbookA As Workbook

Set WorkbookA = Workbooks("WorkbookA.xlsx")

Dim WorkbookA_LASTROW, WorkbookA_LASTCOL As Long

WorkbookA_LASTROW = WorkbookA.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

WorkbookA_LASTCOL = WorkbookA.Sheets(1).Range("A1").CurrentRegion.Columns.Count



Dim WorkbookB As Workbook

Set WorkbookB = Workbooks("WorkbookB.xlsx")

Dim WorkbookB_LASTROW, WorkbookB_LASTCOL As Long

WorkbookB_LASTROW = WorkbookB.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

WorkbookB_LASTCOL = WorkbookB.Sheets(1).Range("A1").CurrentRegion.Columns.Count



Dim ReferenceList As Workbook

Set ReferenceList = Workbooks("ReferenceList.xlsx")

Dim ReferenceList_LASTROW, ReferenceList_LASTCOL As Long

ReferenceList_LASTROW = ReferenceList.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

ReferenceList_LASTCOL = ReferenceList.Sheets(1).Range("A1").CurrentRegion.Columns.Count



Dim i, j As Long

Dim Array1, Array2, Array3 As Variant



'Parse all values to an array, reducing interactions with the application

Array1 = Range(WorkbookA.Sheets(1).Cells(1), WorkbookA.Sheets(1).Cells(WorkbookA_LASTROW, WorkbookA_LASTCOL))

Array2 = Range(ReferenceList.Sheets(1).Cells(1), ReferenceList.Sheets(1).Cells(ReferenceList_LASTROW, ReferenceList_LASTCOL))

Array3 = Range(WorkbookB.Sheets(1).Cells(1), WorkbookB.Sheets(1).Cells(WorkbookB_LASTROW, WorkbookB_LASTCOL))



'Creates a temporary array for Workbook B

ReDim Array3(1 To WorkbookA_LASTROW, 1 To WorkbookA_LASTCOL)



'Check for matches in both Workbook A and Reference List, then copies entire row containing matches to Workbook B

For i = 1 To WorkbookA_LASTROW

If Array1(i, 5) = Array2(i, 1) Then

For j = 1 To WorkbookA_LASTCOL

Array3(i, j) = Array1(i, j)

Next

End If

Next



WorkbookB.Sheets(1).Range(WorkbookB.Sheets(1).Cells(1), WorkbookB.Sheets(1).Cells(WorkbookA_LASTROW, WorkbookB_LASTROW)) = Array3



Workbooks("WorkbookA.xlsx").Close SaveChanges:=True

Workbooks("WorkbookB.xlsx").Close SaveChanges:=True

Workbooks("ReferenceList").Close SaveChanges:=True



MsgBox "GENERATED!"



Application.ScreenUpdating = True

Application.DisplayAlerts = True



 End Sub

Can anyone help me with it?



Many thanks!

 

[TropicalMagic]

It

That would suggest that the output array is empty, when the error occurs hover the mouse over the nr variable, what does it show?

It shows that nr = 0

Does it mean that it's not loading into Workbook B?

 

[Fluff]

It means there were no matches found between the reference list & col E of bookA

 

[TropicalMagic]

It means there were no matches found between the reference list & col E of bookA

I rechecked the referencing of my columns and found that I had accidentally deleted a column before E so it shifted away.

Once I changed it, it worked perfectly!

Here is the working code, comparing Column E in Workbook A's Worksheet 1 to Column A in Workbook C's Worksheet 1, thereafter copying the entire row for matching values to Workbook B's Worksheet 1:

Sub MY_SUB()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim WbkA As Workbook, WbkB As Workbook, WbkC As Workbook
Dim Ary As Variant, Nary As Variant
Dim Dic As Object
Dim r As Long, c As Long, nr As Long

Set WbkA = Workbooks.Open(Application.DefaultFilePath & "\" & "WorkbookA.xlsx")
Set WbkB = Workbooks.Open(Application.DefaultFilePath & "\" & "WorkbookB.xlsx")
Set WbkC = Workbooks.Open(Application.DefaultFilePath & "\" & "ReferenceList.xlsx")

Set Dic = CreateObject("scripting.dictionary")
Dic.comparemode = 1

With WbkC.Sheets(1)
    Ary = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value2
End With

For r = 1 To UBound(Ary)
    Dic(Ary(r, 1)) = Empty
Next r

With WbkA.Sheets(1)
    c = .Cells(1, Columns.Count).End(xlToLeft).Column
    Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, c).Value2
End With

ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
For r = 1 To UBound(Ary)
    If Dic.Exists(Ary(r, 5)) Then
        nr = nr + 1
        For c = 1 To UBound(Ary, 2)
        Nary(nr, c) = Ary(r, c)
        Next c
    End If
Next r

WbkB.Sheets(1).Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary

WbkA.Close True
WbkB.Close True
WbkC.Close True

MsgBox "GENERATED!"

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[TropicalMagic]

It means there were no matches found between the reference list & col E of bookA

I would like to extend my sincere thanks to you for helping me to generate a functioning solution and trouble-shooting the errors!

It performed exactly as I intended!

Much appreciated!

 

[Fluff]

Glad to help & thanks for the feedback.

 

[Marc L]

I considered it but however, I'll be running the report generation daily thus I am seeking a VBA-oriented solution to automate away repetitive effort and human errors.

So you misread / did not understand as I was stating for a quick VBA solution needing ten codelines just using some Excel basics !​

 

[Fluff]

So you misread / did not understand as I was stating for a quick VBA solution needing ten codelines just using some Excel basics !

Then why didn't you just post the code, rather than some vague & ambiguous comment?

 

[Marc L]

Yes with some attachment and a positive answer from the OP and as this way can be found in every Excel forum as this is a well known solution …​

 

[Fluff]

No attachments needed. Especially if it's a "Well known solution"

 

[Marc L]

​

As it depends on the OP skills to adapt a generic code to his need and​

as I do not like to waste my time the reason why I prefer to work on an attachment for accuracy …​