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

Question

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

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

如果是，那么我将根据一些critea从该行中复制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 ，您可以轻松找到该类型的问题。 我在内部For循环中也设置了类似的中断，例如Wilson88。

通过使用您的变量和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