如果存在 Excel VBA 宏，则从列中选择每个单元格并遍历另一个工作簿中的列

Question

我有两个名为“Source1”和“Source2”的工作簿。

对于“Source1”最后一列中的每个单元格，我检查它是否存在于“Source2”最后一列中。

如果是，那么我会根据一些标准从该行中复制 4 个单独的单元格到一个名为“Target”的新工作簿中。

我的宏正在运行，但由于我有数千个单元格要循环，因此我至少需要 10 分钟才能完成宏。我一天要运行很多次，所以我想优化我的代码，这样它会花费更少的时间。

这是我的代码

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

我认为问题出在这部分，当单元格存在时，我不需要循环到最后一行，我应该移动到下一行。

对于 j = 2 到 lRow2
如果 c.Value = Source2.Sheets(1).Cells(j, y + 1).Value 那么 ...

任何建议如何调整我的代码？

Answer 1

集合：VBA.Collection、Scripting.Dictionary、ArrayList、Queue、Stack ...等

集合已针对快速查找进行了优化。因此，它们是匹配值时的理想选择。

考虑匹配两个列表，每个列表都有 1000 个值。假设平均而言，您在列表的一半中找到匹配项，即 (500 * 1000) 或 500K 操作。使用 Collection 会将次数减少到 1000 次迭代 + 1000 次查找。假设每次查找需要 1 到 10 次操作（只是猜测），那么您将减少将两个 1000 个元素列表从 500K 比较到 6K 所需的操作次数。

数组：读取和写入数组比读取和写入文件（工作表）要快得多。

找到匹配项后，您将 4 个值写入新工作表。假设您找到 1000 个匹配项，即对工作表的 4000 次写入操作。如果您将这些值保存在一个数组中，然后将该数组写入工作表，您会将写入操作（到工作表）的数量从 400 减少到 1。

使用这些技术应该可以将运行时间从 10 多分钟减少到 20 秒以下。

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

从你的最后一点开始，你能不能在满足 If 条件时退出循环？比如这样的？

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

代码可以稍微清理一下...加上您关闭“Source1.xlsx”两次...并尝试将 Source1 称为变量，即使它从未声明过。在模块顶部使用Option Explicit 可以让您轻松找到该类型的问题。我也像 Wilson88 一样在内部 For 循环中加入了类似的中断。

通过使用您的变量和With，您应该能够比ActiveWorkbook 和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