根据多个条件返回其他工作表中的匹配值

警告：复杂的情况需要文字墙

我有什么数据

在表A中，我有字母数字在A列，有时在B，C，D列有供应商。

colA colB colC colD H-19328 SupA SupB SupA H-12801 SupC SupD H-32829 H-23123 SupB SupC ....... .... .... .... 

在表B中，列A中有字母数字，列B中有1个供应商。下一列中还有一些其他信息。

  colA colB colC colD H-19328 SupA stuffs stuffs H-52601 SupA stuffs stuffs H-3279 SupA stuffs stuffs H-4987123 SupB stuffs stuffs ....... .... ...... ...... 

在表A中，字母数字在列表中是唯一的。 表A中的数字在表B中可能有也可能没有匹配的数字，反之亦然。 即使数字匹配，供应商可能也可能不匹配。

我想做的事

对于表A中的每个号码，我想检查表B是否与关联的供应商保持该号码。 例如，对于第一个编号H-19328，我将检查B页是否有：

  colA colB colC colD H-19328 SupA stuffs stuffs < This could match twice as it was twice in A H-19328 SupB stuffs stuffs 

我不知道数字/供应商组合是否匹配，如果是，我不知道匹配多less次。 我想从其他列C和D中的表B中检索值。

我有什么代码

我把这些数据放在表A的A栏里。 密钥是数字，供应商信息是绑定到每个密钥的数组中。 这个词典很好用。 这个问题不是关于词典，如果你对他们不好，你仍然可以帮助我。

现在我有一个循环匹配每个键+供应商表b列表，并返回匹配的次数。 为了消除混淆，Dict_Sup是词典。 Dict_sup.items（1）是一个包含供应商的数组。 Dict_sup.items（1）（0）是该数组的第一个条目。 Dict_sup.items（1）（supcount）是该数组的最后一个条目。

 For i = 0 To Dict_Sup.Count - 1 For j = 0 To supcount 'supcount is the size of the array containing the suppliers nb_of_matches = TimesExtracted(Dict_Sup.Keys(i), Dict_Sup.Items(i)(j)) Next j Next 

TimesExtracted函数查找表B（这是一个摘录，表名是SupDocs），并匹配我所提到的匹配数。 这里是：

 Function TimesExtracted(Key As String, Sup As String) As Integer() Dim lastline As Integer Dim AllSupDocs As Range Dim SupDoc As Range lastline = SupDocs.Range("A" & Rows.Count).End(xlUp).Row Set AllSupDocs = SupDocs.Range("E1:E" & lastline) For Each SupDoc In AllSupDocs If SupDoc.Value = Key And SupDoc(, 61).Value = Sup Then Timesextracted = TimesExtracted + 1 End If Next End Function 

我想转换这个函数，以便发送它find的匹配的“东西”，而不是发送匹配的数量。 我想要3个“东西”值。 我尝试使它成为一个数组函数，但我没有成功地重新设置数组以发回适量的结果;

 Function TimesExtracted(Key As String, Sup As String) As String() Dim lastline As Integer Dim AllSupDocs As Range Dim SupDoc As Range Dim tmpArray(0) As String Dim j As Integer lastline = SupDocs.Range("A" & Rows.Count).End(xlUp).Row Set AllSupDocs = SupDocs.Range("E1:E" & lastline) For Each SupDoc In AllSupDocs If SupDoc.Value = Key And SupDoc(, 61).Value = Sup Then ReDim Preserve tmpArray(UBound(tmpArray) To UBound(tmpArray) + 2) 'adds 2 places in the array tmpArray(j) = SupDoc(, 3).Value tmpArray(j + 1) = SupDoc(, 4)Value j = j + 2 End If Next Timesextracted = tmpArray 'Doing this so I can redim End Function 

有没有更好的方法来返回我想要的值？ 我这样做太复杂了吗？ 如果两个答案都不是，那么我需要在最后一个块中修改它以发送一个包含以下信息的数组

 If only SupA matched in column A100: (C100.Value, D100.Value) If supA matched in A100 and matched again in A110: (C100.Value, D100.Value, C110.Value, D110.Value) 

Answer 1

实际上这很简单。 我已经评论的代码，但如果你仍然有一个问题的理解，然后让我知道:)

 Const sep As String = "|" Sub Sample() Dim wsI As Worksheet, wsO As Worksheet, WsRef As Worksheet Dim col As New Collection, itm Dim i As Long, j As Long, lRow As Long Dim aCell As Range Set wsI = Sheet1 '<~~ Sheet A as per your data Set WsRef = Sheet2 '<~~ Sheet B as per your data Set wsO = Sheet3 '~~< New Sheet for Output With wsI '~~> Find last row of col A lRow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> What the code does is joins Col A value in Sheet A '~~> First with Col B and then with Col C and then with '~~> Col D and stores them in a unique collection '~~> Looping from row 1 to last row For i = 1 To lRow '~~> Looping from Col B to Col D For j = 2 To 4 sString = wsI.Cells(i, 1) & sep & wsI.Cells(i, j) On Error Resume Next col.Add sString, CStr(sString) On Error GoTo 0 Next j Next i End With j = 1 '<~~ First Row in Output Sheet '~~> Looping through the unique collection For Each itm In col '~~> Extraction the alphanumerical value and finding it in Sheet B Set aCell = WsRef.Columns(1).Find(What:=Split(itm, sep)(0), LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) '~~> If Found If Not aCell Is Nothing Then wsO.Cells(j, 1).Value = Split(itm, sep)(0) wsO.Cells(j, 2).Value = Split(itm, sep)(1) wsO.Cells(j, 3).Value = aCell.Offset(, 2) wsO.Cells(j, 4).Value = aCell.Offset(, 3) j = j + 1 End If Next End Sub 

注 ：如果您有大量的数据，那么我build议将SheetA和SheetB的数据复制到单独的数组中，然后在内存中执行以上操作，以便执行更快。

---

后续从评论

这是你正在尝试？

 Sub Sample() Dim tmpAr As Variant tmpAr = TimesExtracted("H-19328", "SupA") If IsArray(tmpAr) Then For i = 1 To UBound(tmpAr) Debug.Print tmpAr(i, 1) & "," & tmpAr(i, 2) Next i Else Debug.Print tmpAr End If End Sub Function TimesExtracted(Key As String, Sup As String) As Variant Dim MyAr As Variant Dim wsRef As Worksheet, rngWsRef As Range Dim bCell As Range, oRange As Range Dim ListRange As Range TimesExtracted = "Not Found" Set wsRef = Sheet2 '<~~ Sheet B as per your data Set ListRange = wsRef.Columns(1) n = Application.WorksheetFunction.CountIf(ListRange, Key) If n <> 0 Then ReDim MyAr(n, 2) n = 1 Set oRange = ListRange.Find(what:=Key, LookIn:=xlValues, _ lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not oRange Is Nothing Then Set bCell = oRange MyAr(n, 1) = oRange.Offset(, 2).Value MyAr(n, 2) = oRange.Offset(, 3).Value n = n + 1 Do Set oRange = ListRange.Find(what:=Key, After:=oRange, LookIn:=xlValues, _ lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not oRange Is Nothing Then If oRange.Address = bCell.Address Then Exit Do MyAr(n, 1) = oRange.Offset(, 2).Value MyAr(n, 2) = oRange.Offset(, 3).Value n = n + 1 Else Exit Do End If Loop TimesExtracted = MyAr End If End If End Function 

Answer 2

我想你应该使用已经build立的V-lookup公式。 声明表b列的名称范围AD让我们说“NameR”

在这里，您的查找公式基于拉D栏SheetB中的值

 =vlookup(A2,NameR,4,False) 

在范围中的第一列应始终是查找值，第四列D列返回值。 还要对范围中的第一列进行sorting。