excel - . 发现 VBA 需要很长时间才能跨两个工作表执行

Question

我正在使用 VBA 循环遍历两个工作表上的行，如果它们匹配，则将工作表 2 中的行复制到工作表 1 中。
我的代码应该:

打开第二个工作簿

将所有信息复制到新工作表上的原始工作簿中

然后循环遍历原始工作表(450+行)上的 F 列并在新的“数据”工作表(9,500+行)上找到事件单元格，找到相同的值后，它会复制整行并将其粘贴到原始工作表中，然后循环开始再次。

虽然这确实有效，但我发现这需要超过 20 分钟，这太长了!我是 VBA 的初学者，虽然我已经取得了不错的进步，但我仍然坚持这一点，我已经阅读了 Variants，但老实说，它们让我感到困惑!任何帮助，将不胜感激 :)

Sub AutoUpdate()
    'Opens Enterprise Master Lead File (whichever is present) and auto updates data
    ' in current sheet depending on if ID ref is present

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    'This opens the workbook without setting set date as long as the
    'file is always in the same place

    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim rng As Range, Cel As Range
    Dim sFind As String
    Dim lastRow As Long

    lastRow = Range("F" & Rows.Count).End(xlUp).Row
    Set rng = Range("F2:F" & lastRow)

    Set Wb = ThisWorkbook
   
    Set Wb2 = Workbooks.Open("xxxxxxxxxxx.xlsx") 'opens secondary workbook

    'Deletes unecessary columns
      
    Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Select
    Selection.Delete Shift:=xlToLeft
    
    Range("A2").Select
                    
    Cells.Select
    Selection.Copy
    
    Wb.Activate
    Sheets.Add.Name = "Data"
    Range("A1").Select
    ActiveSheet.Paste
    Wb2.Close 'closes secondary workbook to speed up process
    Wb.Activate
    
    'Loop - finds data in original sheet, finds data in secondary
    'sheet, copies new data and pastes, offsets and starts again
 
    Sheets("Corp Leads").Activate
 
    With Wb
        rng.Select
        'Range("F1").Select
        'ActiveCell.Offset(1, 0).Select
        'Range(Selection, Selection.End(xlDown)).Select
        For Each Cel In rng
            If Cel.Value > 0 Then
                ActiveCell.Select
                sFind = ActiveCell
                                                                                                        
                'Finding matching data
                Sheets("Data").Activate
                Range("F2").Select
                Range(Selection, Selection.End(xlDown)).Select
                Cells.Find(What:=sFind, After:= _
                    ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False).Activate
                ActiveCell.Select

                'copying new data row
                ActiveCell.EntireRow.Select
                Selection.Copy
                    
                'Finding same data again in original sheet
                Sheets("Corp Leads").Activate
                Cells.Find(What:=sFind, After:= _
                    ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False).Activate
                ActiveCell.Select
                
                'Pasting new data
                ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
                
                'Finding reference again to offset for loop
                Cells.Find(What:=sFind, After:= _
                    ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False).Activate
                ActiveCell.Select
                ActiveCell.Offset(1, 0).Select
            End If
        Next Cel
    End With
    Sheets("Data").Delete
    MsgBox ("UPDATED")
End Sub

Answer 1

就像我在评论中提到的那样，它不是 .Find这需要很长时间。是使用.Select/.Activate等这会减慢您的代码。您可能想查看 How to avoid using Select in Excel VBA
此代码是非数组版本。看看我如何避免使用 .Select/.Activate ?

Option Explicit

Sub Sample()
    Dim wbThis As Workbook: Set wbThis = ThisWorkbook
    Dim wbThat As Workbook
    
    '~~> Change this to the relevant worksheet
    Dim wsThis As Worksheet: Set wsThis = wbThis.Sheets("Corp Leads")
    Dim wsNewThis As Worksheet
    Dim wsThat As Worksheet
    
    '~~> Add the data sheet if required
    On Error Resume Next
    Set wsNewThis = wbThis.Sheets("Data")
    On Error GoTo 0
    If wsNewThis Is Nothing Then
        wbThis.Sheets.Add.Name = "Data"
    Else
        wsNewThis.Cells.Clear
    End If

    '~~> Open the relvant workbook
    Set wbThat = Workbooks.Open("xxxxxxxxxxx.xlsx")
    Set wsThat = wbThat.Sheets("RelevantSheetName") 

    Dim lastRow As Long
    Dim lastCol As Long
    
    With wsThat
        .Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Delete
        
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastRow = .Cells.Find(What:="*", _
                       After:=.Range("A1"), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
    
            lastCol = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
        Else
            lastRow = 1: lastCol = 1
        End If
                   
        .Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Copy wsNewThis.Range("A1")
        DoEvents
        .Close (False)
    End With

    Dim aCell As Range
    
    With wsThis
        lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
        For i = lastRow To 2 Step -1
            If .Range("F" & i).Value2 > 0 Then
                Set aCell = wsNewThis.Columns(6).Find(What:=.Range("F" & i).Value2, _
                            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
     
                If Not aCell Is Nothing Then
                    .Rows(i + 1).Insert
                    wsNewThis.Rows(aCell.Row).Copy .Rows(i + 1)
                End If
            End If
        Next i
    End With
    
    Application.DisplayAlerts = False
    wsNewThis.Delete
    Application.DisplayAlerts = True
End Sub