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

Question

警告:复杂情况需要文本墙

我有什么数据

在表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

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

我有什么代码

我将表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

我想转换这个函数,以便它发送匹配的'stuffs',而不是发送匹配数量.我想要3个'东西'值.我试着把它变成一个Array函数,但是我没有成功地重新定义数组以发回适当数量的结果;

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

注意：如果您有大量数据，那么我建议将数据从单独的数组复制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