如何加快索引匹配 Function 與 VBA

Question

我正在尋找一種使用索引來加速我的 vba 代碼的方法，匹配 function 我的代碼運行大約需要 20 秒。 在這里找個解決辦法，貌似Ubound可以更快

感謝您的幫助！

Sub feuille_distinct()

  Dim k As Integer

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual

  timer0 = Timer()

  With Sheets("DEDOUBL")
    ThisWorkbook.Sheets("DEDOUBL").Activate
    col_sinistres = "A"
    Derlig = .Range(col_sinistres & .Rows.Count).End(xlUp).Row
    For k = 2 To Derlig

      Cells(k, 2).Value = WorksheetFunction.Index(Range("ALLSIN_courrier"), 
      WorksheetFunction.Match(Cells(k, 1).Value, Range("ALLSIN_claimnumber"), 0))
      Cells(k, 3).Value = WorksheetFunction.Index(Range("ALLSIN_act"), 
      WorksheetFunction.Match(Cells(k, 1).Value, Range("ALLSIN_claimnumber"), 0))

    Next k
  End With

  Debug.Print Timer - timer0

  ThisWorkbook.Sheets("SIMULATEUR").Activate
  Range("A1").Select

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

請嘗試下一個代碼：

Sub feuille_distinct()
 Dim k As Long, timer0 As Double, sh As Worksheet, col_sinistres As String, Derlig As Long, arrA, arr

 Set sh = ThisWorkbook.Sheets("DEDOUBL")
 timer0 = Timer()

 col_sinistres = "A"
 Derlig = sh.Range(col_sinistres & sh.rows.count).End(xlUp).row
 arrA = sh.Range("A2:A" & Derlig).value 'put the range in an array
 arr = sh.Range("B2:C" & Derlig).value  'put the range in an array
 For k = 1 To UBound(arr)               'iterate between the array elements which is much faster than iterating a range
    arr(k, 1) = WorksheetFunction.Index(Range("ALLSIN_courrier"), WorksheetFunction.match(arrA(k, 1), Range("ALLSIN_claimnumber"), 0))
    arr(k, 2) = WorksheetFunction.Index(Range("ALLSIN_act"), WorksheetFunction.match(arrA(k, 1), Range("ALLSIN_claimnumber"), 0))
 Next k

 sh.Range("B2").Resize(UBound(arr), UBound(arr, 2)).value = arr 'drop the processed array result at once
 Debug.Print Timer - timer0
 
 ThisWorkbook.Sheets("SIMULATEUR").Activate: Range("A1").Select
End Sub

Answer 2

使用字典 object，以聲明編號為鍵，索引為值。

Sub feuille_distinct()

    Const col_sinistres = "A"

    Dim t0 As Single, Derlig As Long, k As Long, i As Long
    Dim dict, key As String, ar, arCour, arAct, arOut
    t0 = Timer()

    ar = Range("ALLSIN_claimnumber")
    arCour = Range("ALLSIN_courrier")
    arAct = Range("ALLSIN_act")

    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(ar)
        key = Trim(ar(i, 1))
        dict(key) = i
    Next
    
    With ThisWorkbook.Sheets("DEDOUBL")
            
         ' copy from sheet
        Derlig = .Range(col_sinistres & .Rows.Count).End(xlUp).Row
        arOut = .Range("A2:C" & Derlig).Value2
        ' update
        For k = 1 To Derlig - 1
            key = Trim(arOut(k, 1))
            If dict.exists(key) Then
                i = dict(key)
                arOut(k, 2) = arCour(i, 1)
                arOut(k, 3) = arAct(i, 1)
            Else
                MsgBox key & " does not exist", vbExclamation
            End If
        Next k
        ' copy to sheet
        .Range("A2:C" & Derlig).Value2 = arOut

    End With
    
    MsgBox "Finished in " & Format(Timer - t0, "0.00") & " secs", vbInformation
    ThisWorkbook.Sheets("SIMULATEUR").Activate
    
End Sub

Answer 3

在主子目錄中使用沒有硬編碼范圍的字典。

'In sheet Phones lookup col F  at LogFileSh sheet col CE,CF and return 
'the results in col D sheet Phones. Row of F+D is 2 and row CE+CF is 2.

Sub RunDictionaryVLookup()
Call GeneralDictionaryVLookup(Phones, LogFileSh, "F", "CE", "CF", "D", 2, 2)
End Sub


Sub GeneralDictionaryVLookup(ByVal shtResault As Worksheet, ByVal shtsource As Worksheet, _
ByVal colLOOKUP As String, ByVal colDicLookup As String, ByVal colDicResault As String, ByVal colRESULT As String, _
ByVal rowSource As Long, ByVal rowResult As Long)
    Dim x As Variant, x2 As Variant, y As Variant, y2() As Variant
    Dim i As Long
    Dim dict As Object
    Dim LastRow As Long

    Set dict = CreateObject("Scripting.Dictionary")

    With shtsource
        LastRow = .Range(colDicLookup & Rows.Count).End(xlUp).row
        x = .Range(colDicLookup & rowSource & ":" & colDicLookup & LastRow).Value
        x2 = .Range(colDicResault & rowSource & ":" & colDicResault & LastRow).Value
        For i = 1 To UBound(x, 1)
            dict.item(x(i, 1)) = x2(i, 1)
            Debug.Print dict.item(x(i, 1))
        Next i
    End With

    'map the values
    With shtResault
        LastRow = .Range(colLOOKUP & Rows.Count).End(xlUp).row
        y = .Range(colLOOKUP & rowResult & ":" & colLOOKUP & LastRow).Value  'looks up to this range
        ReDim y2(1 To UBound(y, 1), 1 To 1)   '<< size the output array
        For i = 1 To UBound(y, 1)
            If dict.Exists(y(i, 1)) Then
                y2(i, 1) = dict(y(i, 1))
            Else
                y2(i, 1) = "NA"
            End If
        Next i
        .Range(colRESULT & rowResult & ":" & colRESULT & LastRow).Value = y2   '<< place the output on the sheet
    End With
End Sub