我正在通过两列（客户名和进程号）遍历ArrayDestination。我正在遍历ArraySourceData来查找上述搜索条件的匹配项（发票编号和金额）。
如果有匹配项，它将被复制到数组中，并且一旦两个循环都完成，结果将被复制到工作表中。
到目前为止，除了循环仅返回第一个匹配项之外，它都是可行的。
如果客户有多个相同的过程号，则循环只会返回所有这些过程的第一个匹配项。
我的b变量看起来有点静态，我尝试用b = b + 1使它振作起来。
为简单起见，我没有发布创建数组部分的信息。有用。如果需要，我可以提供。
Sub search_loop_arrray()
For a = 2 To UBound(ArraySourceData)
varCustomerName = ArraySourceData(a, 3)
varProcessNumber = ArraySourceData(a, 5)
For b = 2 To UBound(ArrayDestination)
If ArrayDestination(b, 3) = varCustomerName And _
ArrayDestination(b, 8) = varProcessNumber Then
ArrayDestination(b, 9) = ArraySourceData(a, 11)
ArrayDestination(b, 10) = ArraySourceData(a, 12)
Exit For
End If
Next b
Next a
'transfer data (invoice number and amount) from ArrayDestination to wsDestination (Column 9 and 10)
For a = 2 To UBound(ArraySourceData)
For b = 9 To 10
wsDestination.Cells(a, b).Value = ArrayDestination(a, b)
Next b
Next a
End Sub
02/02/2020
我在没有数组的嵌套for循环中重写了代码。此代码有效。问题是我的源数据中有重复的过程号。
在我的示例中，我将已找到的过程编号“剪切并粘贴”在称为巧合的工作表中。但由于要处理100.000+行和20+列，我一直希望将所有内容解析为一个数组。
我不知道我的“复制到临时巧合页”在数组中是否有意义？
Sub find_invoice()
Dim wsSourceData As Worksheet
Dim wsResults As Worksheet
Dim wsCoincidences As Worksheet
Dim varCustomer As String
Dim varProcessNumber As Long
Dim varInvoiceNumber As Long
Dim varSDlastrow As Integer
Dim varRElastrow As Long
Dim varCIlastrow As Long
Dim varCounterResults As Long
Set wsResults = ThisWorkbook.Sheets("RESULTS")
Set wsSourceData = ThisWorkbook.Sheets("SOURCEDATA")
Set wsCoincidences = ThisWorkbook.Sheets("COINCIDENCES")
varSDlastrow = wsSourceData.Cells(Rows.Count, 1).End(xlUp).Row
varRElastrow = wsResults.Cells(Rows.Count, 1).End(xlUp).Row
varCIlastrow = wsCoincidences.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To varRElastrow
varCustomer = wsResults.Cells(i, 1)
varProcessNumber = wsResults.Cells(i, 2)
For j = 2 To varSDlastrow
If wsSourceData.Cells(j, 1) = varCustomer And wsSourceData.Cells(j, 2) = varProcessNumber Then
wsResults.Cells(i, 3) = wsSourceData.Cells(j, 3)
wsResults.Cells(i, 4) = wsSourceData.Cells(j, 4)
wsCoincidences.Rows(varCIlastrow).EntireRow.Value = wsSourceData.Rows(j).EntireRow.Value
wsSourceData.Rows(j).EntireRow.Delete
varCIlastrow = varCIlastrow + 1
Exit For
End If
Next j
Next i
End Sub
我不确定您的逻辑是否正确。如果您说需要匹配2个参数，并且几个实体可以包含这两个参数，那么除了找到第一个或最后一个匹配项之外，我看不到如何做。您不需要第三个参数来区分匹配项吗？
您将在下面的示例代码中看到，我假设源数据具有顺序的发票清单，而目标数据具有重复的客户和流程参数。在这种情况下，我假设目标单上的发票匹配也应该是顺序的，即，第二次出现重复均值与第二次出现发票相匹配。因此，在这里，“序列”成为第三个参数，但您的可能会有所不同。
将数据格式化为层次结构也可能更容易：
客户->流程->发票
因此您可以轻松了解发生了什么。 Classes是理想的选择。您的代码很难遵循，因为Exit For仅保证第一个匹配，并且传输循环在ArraySourceData数组的上限上迭代并处理ArrayDestination（我看不到您在尝试什么）除非有错误，否则可以在那里做。
为了向您展示我的意思，创建名为cCustomer，cProcess和cInvoice的三个类（Insert〜> Class Module）。向每个代码添加以下代码：
cCustomer
Option Explicit
Public Name As String
Public Processes As Collection
Public Sub AddInvoice(processNum As String, invoiceNum As String, invAmount As Double)
Dim process As cProcess
Dim invoice As cInvoice
On Error Resume Next
Set process = Processes(processNum)
On Error GoTo 0
If process Is Nothing Then
Set process = New cProcess
With process
.ProcessNumber = processNum
Processes.Add process, .ProcessNumber
End With
End If
Set invoice = New cInvoice
With invoice
.InvoiceNumber = invoiceNum
.Amount = invAmount
process.Invoices.Add invoice
End With
End Sub
Public Function GetProcess(num As String) As cProcess
On Error Resume Next
Set GetProcess = Processes(num)
End Function
Private Sub Class_Initialize()
Set Processes = New Collection
End Sub
cProcess
Option Explicit
Public ProcessNumber As String
Public Invoices As Collection
Public CurrentInvoiceCount As Long
Private Sub Class_Initialize()
Set Invoices = New Collection
End Sub
cInvoice
Option Explicit
Public InvoiceNumber As String
Public Amount As Double
Public ArrayIndex As Long
模块中的以下例程将按照我上面的描述输出数据：
Dim customers As Collection
Dim customer As cCustomer
Dim process As cProcess
Dim invoice As cInvoice
Dim srcData As Variant, dstData As Variant
Dim output() As Variant
Dim i As Long
'Populate the source data array.
'Note: just an example here, use whatever array populating code you have.
With Sheet1 'I've put some dummy data in my Sheet1.
srcData = _
.Range( _
.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 12) _
.Value2
End With
'Populate the destination data array.
'Note: just an example here, use whatever array populating code you have.
With Sheet2 'I've put some dummy data in my Sheet2.
dstData = _
.Range( _
.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 10) _
.Value2
End With
'Convert source array to heirarchical collections.
Set customers = New Collection
For i = 1 To UBound(srcData, 1)
Set customer = Nothing: On Error Resume Next
Set customer = customers(CStr(srcData(i, 3))): On Error GoTo 0
If customer Is Nothing Then
Set customer = New cCustomer
With customer
.Name = CStr(srcData(i, 3))
customers.Add customer, .Name
End With
End If
customer.AddInvoice CStr(srcData(i, 5)), CStr(srcData(i, 11)), CDbl(srcData(i, 12))
Next
'Match destination array.
For i = 1 To UBound(dstData, 1)
Set customer = Nothing: On Error Resume Next
Set customer = customers(CStr(dstData(i, 3))): On Error GoTo 0
If Not customer Is Nothing Then
Set process = customer.GetProcess(CStr(dstData(i, 8)))
If Not process Is Nothing Then
With process
.CurrentInvoiceCount = .CurrentInvoiceCount + 1
If .CurrentInvoiceCount > .Invoices.Count Then
MsgBox "No further invoices for [cust=" & customer.Name & ";" & process.ProcessNumber & "]"
Else
Set invoice = .Invoices(.CurrentInvoiceCount)
invoice.ArrayIndex = i
End If
End With
End If
End If
Next
'Populate the output array.
ReDim output(1 To UBound(dstData, 1), 1 To 2)
For Each customer In customers
For Each process In customer.Processes
For Each invoice In process.Invoices
With invoice
If .ArrayIndex > 0 Then
output(.ArrayIndex, 1) = .InvoiceNumber
output(.ArrayIndex, 2) = .Amount
End If
End With
Next
Next
Next
'Write array to worksheet
Sheet2.Cells(2, 9).Resize(UBound(output, 1), UBound(output, 2)).Value = output
没有看到一些示例数据，很难确定，但是我怀疑我的观点是：如果只有三个参数的组合才能使某些东西变得唯一，那么您将需要与这三个参数进行匹配。
如果您在SOURCEDATA工作表上有100,000行，在RESULTS工作表上有10,000行，那么有2个循环就是1,000,000,000次迭代。一种有效的方法是使用dictionary object，该键使用根据2个匹配条件（col1和col2）构造的键，并由您选择的字符（例如“〜”（波浪号）或“ _”（下划线））连接在一起。扫描SOURCEDATA工作表一次，以建立对行号键的“查找”。然后扫描一次RESULTS表，像以前一样连接2个字段，并使用字典.exists（key）方法查找匹配项，该匹配项将为您提供SOURCEDATA上的相关行号。这是一些代码来说明。我用100,000个源行和10,000个与关键字匹配的随机数据结果行进行了测试，并在RESULTS表上填充col C和D大约需要3秒钟。为性能指标添加一个名为RUNLOG的工作表。它看起来很多代码，但是很多都是日志记录。
Option Explicit
Sub find_invoice2()
Const MSG As Boolean = False ' TRUE to show message boxes
Const RUNLOG As Boolean = False ' TRUE to log matches, no match etc
Dim wb As Workbook, start As Single, finish As Single
start = Timer
Set wb = ThisWorkbook
' set up sheets
Dim wsSourceData As Worksheet, wsResults As Worksheet, wsLog As Worksheet, wsMatch
With wb
Set wsResults = .Sheets("RESULTS")
Set wsSourceData = .Sheets("SOURCEDATA")
Set wsMatch = .Sheets("COINCIDENCES")
Set wsLog = .Sheets("RUNLOG")
End With
' find last row of source and results
Dim lastRowSource As Long, lastRowResults As Long, lastRowLog As Long, lastRowMatch
lastRowSource = wsSourceData.Cells(Rows.Count, 1).End(xlUp).Row
lastRowResults = wsResults.Cells(Rows.Count, 1).End(xlUp).Row
lastRowMatch = wsMatch.Cells(Rows.Count, 1).End(xlUp).Row
' set up log sheets
wsLog.Cells.Clear
wsLog.Range("A1:E1") = Array("Source Row", "Result Row", "Customer~Process", "Message", "Date Time")
wsLog.Cells(2, 4) = "Started"
wsLog.Cells(2, 5) = Time
lastRowLog = 3
' create lookup from Source
' key = Name~ProcessID, value = array row
Dim dict As Object, sKey As String, iRow As Long
Set dict = CreateObject("scripting.dictionary")
With wsSourceData
For iRow = 2 To lastRowSource
sKey = CStr(.Cells(iRow, 1)) & "~" & CStr(.Cells(iRow, 2)) ' customer~process
If Len(sKey) > 1 Then ' skip blanks lines if any
If dict.exists(sKey) Then
dict.Item(sKey) = dict.Item(sKey) & "_" & CStr(iRow)
If MSG Then MsgBox "Ignoring duplicate key in Source Data " & sKey, vbCritical
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 0) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Source : Ignoring duplicate key "
.Offset(0, 4) = Time
End With
lastRowLog = lastRowLog + 1
End If
Else
dict.Add sKey, iRow
'Debug.Print "Dict add", sKey, iRow
End If
End If
Next
End With
If MSG Then MsgBox dict.Count & " records added to dictionary"
wsLog.Cells(lastRowLog, 4) = "Dictionary Built Keys Count = " & dict.Count
wsLog.Cells(lastRowLog, 5) = Time
lastRowLog = lastRowLog + 1 ' blank line to seperate results
' scan results sheet
Dim sDict As String, countMatch As Long, countNoMatch As Long, sMsg As String
Dim ar As Variant, i As Long
countMatch = 0: countNoMatch = 0
Application.ScreenUpdating = False
With wsResults
For iRow = 2 To lastRowResults
sKey = CStr(.Cells(iRow, 1)) & "~" & CStr(.Cells(iRow, 2)) ' customer~process
If Len(sKey) > 1 Then 'skip blanks lines if any
If dict.exists(sKey) Then
' split string to get multiple lines
sDict = dict(sKey)
ar = Split(sDict, "_")
.Cells(iRow, 3).Value = UBound(ar) + 1
For i = 0 To UBound(ar)
.Cells(iRow, 4).Offset(0, i) = ar(i)
Next
lastRowMatch = lastRowMatch + 1
countMatch = countMatch + 1
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 0) = sDict
.Offset(0, 1) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Match - Source record deleted"
.Offset(0, 4) = Time
End With
lastRowLog = lastRowLog + 1
End If
'Debug.Print iRow,sDict, sKey,
Else
' no match
If MSG Then MsgBox "Results Row " & iRow & ": NO match for " & sKey, vbExclamation, "NO match"
countNoMatch = countNoMatch + 1
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 1) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Results : NO match"
.Offset(0, 4) = Time
.EntireRow.Interior.Color = vbYellow
End With
.Cells(iRow, 3).Resize(1, 2).Interior.Color = vbYellow
lastRowLog = lastRowLog + 1
'Debug.Print iRow, sDict, sKey,
End If
End If
End If
Next
End With
Application.ScreenUpdating = True
wsLog.Cells(lastRowLog, 4) = "Program Ended Rows Scanned = " & lastRowResults - 1
wsLog.Cells(lastRowLog, 5) = Time
wsLog.Columns.AutoFit
wsLog.Activate
wsLog.Columns("A:B").HorizontalAlignment = xlCenter
wsLog.Range("A1").Select
' result
finish = Timer
sMsg = "Matched = " & countMatch & vbCrLf _
& "NO match = " & countNoMatch & vbCrLf _
& "Run time (secs) = " & Int(finish - start)
MsgBox sMsg, vbInformation, "Results"
End Sub