Arrays 循环遍历数组并基于一个或多个搜索条件返回多行
我通过两列（客户名称和流程编号）循环执行ArrayDestination。Arrays 循环遍历数组并基于一个或多个搜索条件返回多行,arrays,excel,vba,search,Arrays,Excel,Vba,Search,我通过两列（客户名称和流程编号）循环执行ArrayDestination。 我正在通过ArraySourceData查找上述搜索条件的匹配项（发票号和金额） 如果存在匹配项，则将其复制到数组中，并在两个循环完成后将结果复制到工作表中 到目前为止，除了循环只返回第一个匹配项外，它仍然有效 如果客户有多个相同的流程编号，则循环仅返回所有流程编号的第一个匹配项 我的b变量看起来有点静态，我试着用b=b+1来使它振作起来 为了简单起见，我没有发布创建数组部分的帖子。它起作用了。如果需要，我可以提供 Su
我正在通过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
2020年2月2日 我在没有数组的嵌套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
我不确定你的逻辑是否正确。如果您说需要匹配两个参数，并且几个实体可以包含这两个参数，那么除了查找第一个或最后一个引用之外，我看不出您还能做什么。您不需要第三个参数来区分匹配项吗 您将在下面的示例代码中看到，我假设源数据具有连续的发票列表，而目标数据具有重复的客户和流程参数。在这种情况下，我假设目的地工作表上匹配的发票也应该是连续的，即重复的第二次出现意味着匹配发票的第二次出现。所以这里，“序列”变成了第三个参数，但是你的可能不同 将数据格式化为层次结构也可能更容易： 客户->流程->发票 所以你可以更容易地看到发生了什么<代码>类非常适合于此。您的代码很难理解，因为
退出数组源数据数组目标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
Option Explicit
Public ProcessNumber As String
Public Invoices As Collection
Public CurrentInvoiceCount As Long
Private Sub Class_Initialize()
Set Invoices = New Collection
End Sub
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 sheet上有100000行，结果sheet上有10000行，那么有2个循环就是100000000次迭代。有效的方法是使用一个基于2个匹配条件（col1和col2）构造的键，该键由您选择的字符（如“~”（波浪号）或“\”（下划线）连接。扫描SOURCEDATA sheet一次，以“查找”关键行编号。然后扫描结果表一次，像以前一样连接这两个字段，并使用dictionary.exists（key）方法查找匹配项将为您提供SOURCEDATA上的相关行号。下面是一些代码来说明。我用100000个源行和10000个结果行对它进行了测试，这些随机数据与键匹配，在结果表上填写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
不要硬编码数组的下限，使用
LBound