VBA – 数组赋值For循环

我必须循环search多个范围，并find匹配到100K +logging。 问题是，当将值赋给variablesArr2（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的值（因为你没有select的事情）和一个单一维数组来保存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 

注意我在哪里redrrrrr。 它会得到一个价值的任何一种方式，所以你需要扩大其规模，准备接受一个OK / NO 。

的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栏的200Klogging
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") 

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