从列中选择每个单元格，并在另一个工作簿中的列中循环（如果存在）Excel VBA宏

Question

I have 2 workbooks called "Source1" and "Source2".

For each cell in the last column of "Source1" I check if it exists in the last column of "Source2".

If yes, then I copy 4 separate cells from that row based on some critea into a new workbook called "Target".

My macro is working but as I have thousands of cells to loop through, it takes me at least 10 min till the macro finishes. I am running it many times a day so I want to optimize my code so that it will take less time.

Here is my code

Sub Loop_Cells()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.SheetsInNewWorkbook = 1

  Dim Source, Source2, Target As Workbook
  Dim c As Range
  Dim lRow, lRow2 As Long
  Dim x, y, w As Integer

  Set Source = Workbooks.Open("C:\Reports\Source1.xlsx")

  Source.Activate

  x = ActiveSheet.UsedRange.Columns.Count
  ActiveSheet.Cells(1, x + 1) = "Concate"

  lRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To lRow
    ActiveSheet.Cells(i, x + 1).Value = ActiveSheet.Cells(i, 6).Value & ActiveSheet.Cells(i, 7).Value
  Next i
  ActiveSheet.Columns(x + 1).NumberFormat = "0"

  Set Source2 = Workbooks.Open("C:\Reports\Source2.xlsx")

  Source2.Activate
  y = ActiveSheet.UsedRange.Columns.Count
  ActiveSheet.Cells(1, y + 1) = "Concate"

  lRow2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To lRow2
    ActiveSheet.Cells(i, y + 1).Value = ActiveSheet.Cells(i, 48).Value & ActiveSheet.Cells(i, 3).Value
  Next i
  ActiveSheet.Columns(y + 1).NumberFormat = "0"

  Set Target = Workbooks.Add
  Target.Sheets(1).Name = "ExistCells"    

  Source.Sheets(1).Activate         
  w = 1        
  For Each c In Source1.Sheets(1).UsedRange.Columns(x + 1).Cells            
    For j = 2 To lRow2
      If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then
        Target.Sheets(1).Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48).Value
        Target.Sheets(1).Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3).Value
        Target.Sheets(1).Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27).Value
        Target.Sheets(1).Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41).Value

        w = w + 1    
      End If
    Next j
  Next c

  Workbooks("Source1.xlsx").Close SaveChanges:=False
  Workbooks("Source1.xlsx").Close SaveChanges:=False

  Target.Activate
  ActiveWorkbook.SaveAs FileName:= "C:\Reports\Target.xlsx", _
                        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True      
End Sub

I think the problem is in this part, when the cell exists I don't need to loop till the last row and I should move to the next.

For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then ...

Any Suggestions how to adjust my code?

Answer 1

Collections: VBA.Collection, Scripting.Dictionary, ArrayList, Queue, Stack ... etc.

Collections are optimized for fast lookups. For this reason,they are ideal when matching values.

Consider matching two lists each with 1000 values. Assuming that on average you find a match half way through the list, that's (500 * 1000) or 500K operations. Using a Collection would reduce the number to 1000 iterations + 1000 lookups. Assuming that it takes 1 to 10 operations per lookup (just a guess) then you would reduce the number of operations that it takes to compare two 1000 element lists from 500K to 6K.

Arrays: Reading and writing to arrays is much faster then reading and writing to file (worksheet).

Once a match is found you write 4 values to the new worksheet. Let's say you find 1000 matches, that's 4000 write operations to the worksheet. If instaed you hold these values in an array and then write the array to the worksheet you'll reduce the number of write operations (to the worksheet) from 400 to 1.

Using these techniques should reduce the run time from 10+ minutes to under 20 seconds.

Sub NewLoop()
    Application.ScreenUpdating = False
    Application.SheetsInNewWorkbook = 1

    Dim data As Variant, result As Variant
    Dim lastRow As Long, x As Long, x1 As Long
    Dim key As String
    Dim list As Object
    Set list = CreateObject("System.Collections.ArrayList")

    With Workbooks.Open("C:\Reports\Source1.xlsx")
        With .Worksheets(1)
            data = .Range("F2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
            For x = 1 To UBound(data, 1)
                'Create a Unique Identifier using a pipe to delimit the data
                'This will keep the data from mixing

                key = data(x, 1) & "|" & data(x, 2)
                If Not list.Contains(key) Then list.Add key
            Next
        End With
        .Close SaveChanges:=False
    End With

    With Workbooks.Open("C:\Reports\Source2.xlsx")
        With .Worksheets(1)
            lastRow = .Range("A" & Rows.Count).End(xlUp).Row
            ReDim result(1 To lastRow, 1 To 4)

            For x = 2 To lastRow
                'Create a Unique Identifier using a pipe to delimit the data
                'This will keep the data from mixing

                key = .Cells(i, 48).Value & "|" & .Cells(i, 3).Value
                If list.Contains(key) Then
                    x1 = x1 + 1
                    result(x1, 1) = .Cells(j, 48).Value
                    result(x1, 2) = .Cells(j, 3).Value
                    result(x1, 3) = .Cells(j, 27).Value
                    result(x1, 4) = .Cells(j, 41).Value
                End If
            Next
        End With
        .Close SaveChanges:=False
    End With

    With Workbooks.Add
        With Worksheets(1)
            .Name = "ExistCells"
            .Range("A1:D1").Resize(x1).Value = Results
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Answer 2

Following on from your last point, could you not just exit the loop when the If condition is met? Something like this for example?

For j = 2 To lRow2

    If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then

        Target.Sheets(1).Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48).Value
        Target.Sheets(1).Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3).Value
        Target.Sheets(1).Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27).Value
        Target.Sheets(1).Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41).Value

        w = w + 1

        GoTo ExitLoop

    End If

Next j

ExitLoop:

Answer 3

The code could be cleaned up a bit...plus you were closing "Source1.xlsx" twice...and tried to refer to Source1 as a variable even though it was never declared. Using Option Explicit at the top of the module will allow you find that type of issue easily. I put in a similar break in the inner For loop like Wilson88 as well.

By using your variables and With you should be able to speed it up some over ActiveWorkbook and ActiveSheet ...

Sub Loop_Cells()
  Dim Source As Workbook, Source2 As Workbook, Target As Workbook
  Dim w As Integer, x As Integer, y As Integer
  Dim lRow As Long, lRow2 As Long
  Dim c As Range

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.SheetsInNewWorkbook = 1

  Set Source = Workbooks.Open("C:\Reports\Source1.xlsx")
  With Source
    x = .UsedRange.Columns.Count
    .Cells(1, x + 1) = "Concate"

    lRow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lRow
      .Cells(i, x + 1) = .Cells(i, 6). & .Cells(i, 7)
    Next i
    .Columns(x + 1).NumberFormat = "0"
  End With

  Set Source2 = Workbooks.Open("C:\Reports\Source2.xlsx")

  With Source2
    y = .UsedRange.Columns.Count
    .Cells(1, y + 1) = "Concate"
    lRow2 = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lRow2
      .Cells(i, y + 1). = .Cells(i, 48) & .Cells(i, 3)
    Next i
    .Columns(y + 1).NumberFormat = "0"
  End With

  Set Target = Workbooks.Add
  With Target.Sheets(1)
    .Name = "ExistCells"
    w = 1        
    For Each c In Source.Sheets(1).UsedRange.Columns(x + 1).Cells            
      For j = 2 To lRow2
        If c.Value = Source2.Sheets(1).Cells(j, y + 1) Then
          .Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48)
          .Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3)
          .Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27)
          .Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41)

          w = w + 1
          Exit For
        End If
      Next j
    Next c
  End With

  Source.Close SaveChanges:=False
  Source2.Close SaveChanges:=False

  Target.SaveAs FileName:= "C:\Reports\Target.xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True      
End Sub