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!

 

[Rokas19990319]

Hello Fluff, I found this code and it is absolutely amazing, but is it possible to make it paste different values rather than ones that match and also post to workbook A instead of new one , thank you! I hope you see this

 

[Rokas19990319]

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

Hello Fluff, I found this code and it is absolutely amazing, but is it possible to make it paste different values rather than ones that match and also post to workbook A instead of new one , thank you! I hope you see this

 

[Fluff]

As you have started a new thread for this question, you need to stick to that thread. Thanks

 

[Rokas19990319]

As you have started a new thread for this question, you need to stick to that thread. Thanks

Oh okay, noted