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!

 

[Fluff]

Are all three workbooks open when you run the code?
If not what are their file paths?

 

[Marc L]

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

Hi, rather than a gas factory code I would better go with a quick enough Excel formula and an advanced filter even under VBA, done in ten codelines …​

​

 

[TropicalMagic]

Are all three workbooks open when you run the code?
If not what are their file paths?

Thanks for responding!

Nope, but the code will also open the workbooks at the beginning:

Workbooks.Open(Application.DefaultFilePath & "\" & "WorkbookA.xlsx")
Workbooks.Open(Application.DefaultFilePath & "\" & "WorkbookB.xlsx")
Workbooks.Open(Application.DefaultFilePath & "\" & "ReferenceList.xlsx")

 

[TropicalMagic]

Hi, rather than a gas factory code I would better go with a quick enough Excel formula and an advanced filter even under VBA, done in ten codelines …​

​

Thanks for responding!

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.

 

[Fluff]

Ok, how about

Sub TropicalMagic()
   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("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
   End With
   For r = 1 To UBound(Ary)
      Dic(Cl.Value) = 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
   Wbk.Sheets(1).Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
   
   WbkA.Close True
   WbkB.Close True
   WbkC.Close True
End Sub

 

[TropicalMagic]

Ok, how about

Sub TropicalMagic()
   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("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
   End With
   For r = 1 To UBound(Ary)
      Dic(Cl.Value) = 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
   Wbk.Sheets(1).Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
 
   WbkA.Close True
   WbkB.Close True
   WbkC.Close True
End Sub

Thanks for responding!

However, I have run into a Run-Time Error 424 : Object Required at the "Dic(Cl.Value) = Empty" line.

Even after I included a "Dim Cl As Range", a new Run-Time Error 91 : Object Variable or With Block Variable Not Set at the "Dic(Cl.Value) = Empty" line.

Sub TropicalMagic()
   Dim WbkA As Workbook, WbkB As Workbook, WbkC As Workbook
   Dim Ary As Variant, Nary As Variant
   Dim Dic As Object
   Dim Cl As Range
   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("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
   End With
   For r = 1 To UBound(Ary)
      Dic(Cl.Value) = 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
   Wbk.Sheets(1).Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
   
   WbkA.Close True
   WbkB.Close True
   WbkC.Close True
End Sub

Not sure how to address the issue.

Many thanks!

 

[Fluff]

Helps if I put my brain in gear. It should be

      Dic(Ary(r, 1)) = Empty

 

[TropicalMagic]

Helps if I put my brain in gear. It should be

      Dic(Ary(r, 1)) = Empty

Thanks for your rapid response!

No worries.

However, I have run into a Run-Time Error 1004 : Application-defined or Object-Defined Error at the

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

 

[Fluff]

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