VBA - 数组赋值for循环

Question

我必须循环搜索多个范围并找到匹配100k +记录。问题是在为变量Arr2（i，1）赋值时出现不匹配错误。

      Dim Arr1, Arr2                          As Variant
      Dim Wks0, Wks1                          As Worksheet
      Dim i                                   As Integer
      Dim Row0, Row1                          As Long
      Dim C                                   As Object
      Set Wks0 = Sheets("HOST")
      Set Wks1 = Sheets("OFICI_BANC_USA")

      '-- Create array of range -------------------------------------------*
      Row0 = Wks0.Cells(Rows.Count, "A").End(xlUp).Row 
      Row1 = Wks1.Cells(Rows.Count, "A").End(xlUp).Row
      Arr1 = Wks1.Range("A2:A" & Row1)    

     '-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
      For i = 1 To 5 'UBound(Arr1)
          With Wks0.Range("A2:A" & Row0)
              Set C = .Find(Arr1(i, 1), LookAt:=xlPart,SearchOrder:=xlByRows, SearchDirection:=xlNext)
              If Not C Is Nothing Then
                  'ReDim Preserve Arr2(i, 1)
                  Arr2(i, 1) = "OK"
              Else
                  Arr2(i, 1) = "NO"
              End If
          End With
      Next

     ' Transpose new array onto worksheet -------------------------------*
      Wks1.Range("B2:B6") = WorksheetFunction.Transpose(Arr2)
     'Arr1 = Nothing
     'Arr2 = Nothing

Answer 1

我认为你想要处理来自wks1的值的二维数组（因为你没有选择）和一个​​单一维度的数组来保持 OK / NO 值。

Sub t()
    Dim Arr0() As Variant, Arr1() As Variant, Arr2() As Variant
    Dim Wks0 As Worksheet, Wks1 As Worksheet
    Dim i       As Long
    Dim Row0 As Long, Row1 As Long
    Dim C       As Range

    Set Wks0 = Sheets("HOST")
    Set Wks1 = Sheets("OFICI_BANC_USA")

    '-- Create array of range -------------------------------------------*
    Row0 = Wks0.Cells(Wks0.Rows.Count, "A").End(xlUp).Row
    Row1 = Wks1.Cells(Wks1.Rows.Count, "A").End(xlUp).Row
    Arr1 = Wks1.Range("A2:A" & Row1)

    '-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
    For i = 1 To UBound(Arr1, 1)
        With Wks0.Range("A2:A" & Row0)
            Set C = .Find(Arr1(i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
            ReDim Preserve Arr2(i)  '<~~ NOTE ReDim single dimensioned array here!
            If Not C Is Nothing Then
                Arr2(i) = "OK"
            Else
                Arr2(i) = "NO"
            End If
        End With
    Next

    ' Transpose new array onto worksheet -------------------------------*
    Wks1.Range("B2").Resize(UBound(Arr2), 1) = WorksheetFunction.Transpose(Arr2)

End Sub

请注意我已重新定位arr2的位置。它会以任何方式获得价值，因此您需要扩大其规模以准备接收确定 / 否。

<强> Scripting.Dictionary

Sub tt()
    Dim arr As Variant, dHOST As Object
    Dim Wks0 As Worksheet, Wks1 As Worksheet
    Dim i As Long, j As Long
    Dim Row0 As Long, Row1 As Long
    Dim c As Range, rHOST As Range

    Debug.Print Timer
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set Wks0 = Worksheets("HOST")
    Set Wks1 = Sheets("OFICI_BANC_USA")
    Set dHOST = CreateObject("Scripting.Dictionary")
    dHOST.CompareMode = vbTextCompare

    '-- Create dictionary of HOST range --------------------------
    Row0 = Wks0.Cells(Wks0.Rows.Count, "A").End(xlUp).Row
    arr = Wks0.Range("A2:D" & Row0).Value2
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            'If Not dHOST.Exists(arr(i, j)) Then _
                dHOST.Item(arr(i, j)) = j           '<~~ for first match (adds 1½ seconds)
            dHOST.Item(arr(i, j)) = j               '<~~ for overwrite match
        Next j
    Next i

    '-- Create array of OFICI_BANC_USA range ----------------------
    Row1 = Wks1.Cells(Wks1.Rows.Count, "A").End(xlUp).Row
    arr = Wks1.Range("A2:E" & Row1).Value2
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) + 1 To UBound(arr, 2)
            arr(i, j) = "NO"    '<~~ seed all NO matches
        Next j
    Next i

    '-- Loop arrayed values from sheet OFIC_BANC_USA found value in dictionary HOST values --
    For i = LBound(arr, 1) To UBound(arr, 1)
        If dHOST.Exists(arr(i, 1)) Then _
            arr(i, dHOST.Item(arr(i, 1)) + 1) = "OK"
    Next i

    ' Stuff it all back into worksheet -------------------------------*
    With Wks1.Range("A2:E" & Row1)
        .Cells = arr
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Debug.Print Timer

End Sub

  

^{OFICI_BANC_USA工作表A栏中的200K记录    HOSTS工作表中各列4列@ 50K行    ~76％的匹配率}
    _{14.73秒从头到尾}

Answer 2

除@ VincentG的评论外，您还需要明确说明您使用的Rows。此外，我取消注释ReDim，现在似乎正在运作：

Sub t()
Dim Arr0() As Variant, Arr1() As Variant, Arr2() As Variant
Dim Wks0 As Worksheet, Wks1 As Worksheet
Dim i       As Integer
Dim Row0 As Long, Row1 As Long
Dim C       As Object
Set Wks0 = Sheets("HOST")
Set Wks1 = Sheets("OFICI_BANC_USA")

'-- Create array of range -------------------------------------------*
Row0 = Wks0.Cells(Wks0.Rows.Count, "A").End(xlUp).Row
'Arr0 = Wks0.Range("A2:A" & Row0)
Row1 = Wks1.Cells(Wks1.Rows.Count, "A").End(xlUp).Row
Arr1 = Wks1.Range("A2:A" & Row1)

'-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
For i = 1 To 5               'UBound(Arr1)
    With Wks0.Range("A2:A" & Row0)
        Set C = .Find(Arr1(i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not C Is Nothing Then
            ReDim Preserve Arr2(i, 1)
            Arr2(i, 1) = "OK"
        Else
            Arr2(i, 1) = "NO"
        End If
    End With
Next

' Transpose new array onto worksheet -------------------------------*
Wks1.Range("B2:B6") = WorksheetFunction.Transpose(Arr2)
'Arr0 = Nothing
'Arr1 = Nothing
'Arr2 = Nothing
End Sub

Answer 3

我想我理解你要做的事情。我把这两张纸设置成这样：

然后使用以下代码：

Sub jorge()
    Application.ScreenUpdating = False
    Dim Arr1 As Variant, Arr2 As Variant, Arr3 As Variant
    Dim Wks0 As Worksheet, Wks1 As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim Row0 As Long, Row1 As Long

    Set Wks0 = Sheets("HOST")
    Set Wks1 = Sheets("OFICI_BANC_USA")

    '-- Create array of range -------------------------------------------*
    Row0 = Wks0.Cells(Rows.Count, "A").End(xlUp).Row
    Row1 = Wks1.Cells(Rows.Count, "A").End(xlUp).Row
    Arr1 = Wks1.Range("A2:A" & Row1)
    ReDim Arr2(1 To Row1, 1 To 4)
    Arr3 = Wks0.Range("A2:D" & Row0)
    '-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
    For i = 1 To UBound(Arr1, 1)
        For j = 1 To UBound(Arr3, 2)
            Arr2(i, j) = "NO"
            For k = 1 To UBound(Arr3, 1)
                If Arr3(k, j) = Arr1(i, 1) Then
                    Arr2(i, j) = "OK"
                    Exit For
                End If
            Next k
        Next j
    Next i

    Wks1.Range("B2").Resize(Row1, 4).value = Arr2
    Application.ScreenUpdating = true
End Sub

我明白了：

这个公式将做同样的事情，把它放在B2：

=IF(ISNUMBER(MATCH($A2,HOST!A:A,0)),"OK","NO")

横向和向下复制。对于大量的计算，这可能是令人望而却步的，但是如果你想尝试它就在这里。