. 发现 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

就像我在 cmets 中提到的，这不是 .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

Answer 2

这是一个使用数组和字典查找的版本，它可以比使用Find() 的循环更快

Sub Update()

    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws
    Dim wsdata As Worksheet, wsImport As Worksheet
    Dim dict As Object, k, i As Long, m, arrF
    
    '~~> Change this to the relevant worksheet
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("Worksheet1")
    Set ws2 = wb1.Sheets("Worksheet2")
    
    On Error GoTo haveError
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".xlsx") 'opens secondary workbook
    Set wsdata = wb2.Sheets(1)                          'for example, or use name if known
    wsdata.Range("C:D,G:K,M:Q,S:S,U:W,Z:Z,AD:AD").Delete 'Delete unecessary columns
    
    'create a lookup on ColF in data source and map to row number
    Set dict = CreateObject("scripting.dictionary")
    '   get data into an array (1 to #rows, 1 to #cols)
    arrF = wsdata.Range("F1:F" & wsdata.Cells(Rows.Count, "F").End(xlUp).Row).Value
    For i = 2 To UBound(arrF)      'loop over the array; exclude header
        dict(arrF(i, 1)) = i         'maps row number to value
    Next i
    
    For Each ws In Array(ws1, ws2) 'update each sheet in turn
        arrF = ws.Range("F1:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row).Value
        For i = 2 To UBound(arrF)  'exclude header
            k = arrF(i, 1)
            If k > 0 Then
                If dict.exists(k) Then
                    ws.Rows(i).Value = wsdata.Rows(dict(k)).Value 'faster
                    'wsdata.Rows(dict(k)).Copy ws.Cells(i, 1)
                End If
            End If
        Next i
    Next ws

    'wb2.Close False 'don't save changes

    MsgBox "UPDATED"
haveError:
    Application.Calculation = xlCalculationAutomatic

End Sub

Answer 3

因此，在 Siddharth (cmets) 的帮助下，我想出了一些可以在不到一分钟内完成查询的代码，而不是一张，而是两张单独的表格，这就是整个任务！

仍在使用一些 .select 语句，我知道这很顽皮，但它仍然表现得非常好。很高兴更新任何进一步的建议，发现今天与 cmets 互动非常有帮助！ :)

可能不是最简洁的代码，但它可以工作！

子更新()

Application.DisplayAlerts = False Application.ScreenUpdating = False

Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim wb2 As Workbook

'~~> Change this to the relevant worksheet
Dim ws1 As Worksheet: Set ws1 = wb1.Sheets("Worksheet1")
Dim ws2 As Worksheet: Set ws2 = wb1.Sheets("Worksheet2")
Dim wsdata As Worksheet
   

Dim lastRow As Long
Dim lastCol As Long

   Set wb1 = ThisWorkbook
    
    Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".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

wb1.Activate
Sheets.Add.Name = "Data"
Range("A1").Select
ActiveSheet.Paste
wb2.Close 'closes secondary workbook to speed up process
wb1.Activate


Dim aCell As Range
Dim i As Long
Set wsdata = wb1.Sheets("Data")

'Finds matching values (externel ref ID) using Corp Leads and Data sheets

With ws1
    lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
    For i = lastRow To 2 Step -1
        If .Range("F" & i).Value2 > 0 Then
            Set aCell = wsdata.Columns(6).Find(What:=.Range("F" & i).Value2, _
                        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            
            
            'inserts updated rows into corp leads sheet
            
            If Not aCell Is Nothing Then
                wsdata.Rows(aCell.Row).Copy .Rows(i)
            End If
        End If
    Next i
End With



With ws2
        lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
    For i = lastRow To 2 Step -1
        If .Range("F" & i).Value2 > 0 Then
            Set aCell = wsdata.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
                wsdata.Rows(aCell.Row).Copy .Rows(i)
            End If
        End If
    Next i
End With

wsdata.Delete
Application.DisplayAlerts = True

 MsgBox "UPDATED"

 End Sub