.Find VBA 跨两个工作表执行需要很长时间

.Find VBA taking a long time to execute across two worksheets

我正在使用 VBA 循环遍历两个工作 sheet 上的行,如果它们匹配,则将行从 sheet 2 复制到 sheet 1。

我的代码应该:

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

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

正如我在评论中提到的,并不是 .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

因此,在 Siddharth(评论)的帮助下,我想出了一些有效的代码,并且在不到一分钟的时间内完成了查询,而不是一张而是两张单独的工作表,这就是整个任务!

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

可能不是最简洁的代码,但它确实有效!

子更新()

Application.DisplayAlerts = 假 Application.ScreenUpdating = 假

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

这是一个使用数组和字典查找的版本,它比使用 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