数字与列表之间的复杂相似匹配

Question

我想在数字列表中获得更相似的数字。 在 A 列中是一些数字，在 B 列中是该数字的相关代码。 在 C 列中是我想为其找到最相似值的条目，如果可能，将 output 放在 D 列中，显示相关产品。 我希望有意义。

我在 colors 中显示了每个条目更相似的“短代码”。

我的卑微尝试如下所示，我使用索引和匹配来查找完全匹配，但对于最接近的匹配，我不知道如何开始。

我喜欢使用 VBA 来实现它，因为我会将它应用于不在列中的值，而是在 vba 数组中。

Sub GestClosestMatch()

Set wf = WorksheetFunction

ExactMatch = wf.Index(Range("B2:B15"), Application.Match(Range("C12"), Range("A2:A15"), 0))
ClosestMatch = ?

End Sub

我已经在这个线程中测试了 UDF，但显示了#NAME? 尝试时出错。

这就是它看起来数据的方式，以便于理解

输入数据如下：

+------------+---------+-----------+
| SHORT CODE | PRODUCT | ENTRIES   |
+------------+---------+-----------+
| 237        | CMR     | 18763044  |
+------------+---------+-----------+
| 230        | MUS     | 187635    |
+------------+---------+-----------+
| 61         | APS     | 23092     |
+------------+---------+-----------+
| 31         | NLW     | 3162      |
+------------+---------+-----------+
| 599        | ANT     | 38050     |
+------------+---------+-----------+
| 358        | FIY     | 33        |
+------------+---------+-----------+
| 33751      | FRJ     | 49185     |
+------------+---------+-----------+
| 65         | SGP     | 51078     |
+------------+---------+-----------+
| 1721       | SXM     | 1246      |
+------------+---------+-----------+
| 1876       | QAM     | 389094702 |
+------------+---------+-----------+
| 81         | JHN     | 38909     |
+------------+---------+-----------+
| 124622     | BRB     | 4475      |
+------------+---------+-----------+
| 38909      | PUK     |           |
+------------+---------+-----------+
| 3890947021 | JIM     |           |
+------------+---------+-----------+

更新

如果我以前像这样加载 arrays 中的数据：

Sub DataStoredInArrays()
Dim CodesArr(1 To 14, 1 To 2)
Dim EntriesArr(1 To 12, 1 To 3)

For i = 1 To 14
    For j = 1 To 2
        CodesArr(i, j) = Cells(i + 1, j)
    Next
Next

For i = 1 To 12
        EntriesArr(i, 1) = "X"
        EntriesArr(i, 2) = Cells(i + 1, "C")
        EntriesArr(i, 3) = Cells(i + 1, "D")
Next

End Sub

arrays 的结构是这样的，在 EntriesArr 的第三“列”中有EntriesArr ：

Answer 1

尝试这个：

Option Explicit

'finds the first instance of string in a range
Function FindLongestMatch(srcArray As Range, valueToFind As Range) As Variant

    Dim c As Range, a1 As Integer, a2 As Integer
    Dim retVal As Variant
    
    retVal = ""
    
    If Trim(valueToFind) = "" Then GoTo Exit_FindLongestMatch
    
    For Each c In srcArray
        a1 = InStr(1, valueToFind, c.Value, vbTextCompare)
        a2 = InStr(1, c.Value, valueToFind, vbTextCompare)
        If a1 > 0 Or a2 > 0 Then
            retVal = c.Value
            Exit For
        End If
    Next c


Exit_FindLongestMatch:
    FindLongestMatch = retVal

End Function

然后，在D列中添加以下公式； =FindLongestMatch($A$2:$A$15;$C2)并向下填充到范围中的最后一行。

注意：替换; ,在需要时。

这应该返回：

现在，您可以在E列中使用VLookup公式；）

随意改进 function 以上以满足您的需求。 例如，如果您更换

retVal = c.Value

和

retVal = c.Offset(ColumnOffset:=1).Value

你会得到一个产品名称。

[编辑]

改进版本 - 根据 OP 的评论。 注意：您不能在下面的代码中使用Range.Offset() function。 您必须在另一列中使用VLookup function。

'finds the best match
Function FindLongestMatch(srcArray As Range, valueToFind As Range) As Variant

    Dim c As Range, a1 As Integer, a2 As Integer
    Dim retVal As Variant
    
    retVal = ""
    
    If Trim(valueToFind) = "" Then GoTo Exit_FindLongestMatch
    
    For Each c In srcArray
        a1 = InStr(1, valueToFind, c.Value, vbTextCompare)
        a2 = InStr(1, c.Value, valueToFind, vbTextCompare)
        If a1 > 0 Or a2 > 0 Then
            If Len(Left(c.Value, Len(valueToFind))) > Len(retVal) Then retVal = c.Value
        End If
    Next c


Exit_FindLongestMatch:
    FindLongestMatch = retVal

End Function

Answer 2

两个方向部分匹配

编码

Option Explicit

Sub matchValues()
    Const ProcName As String = "matchValues"
    On Error GoTo clearError
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A2"
    Const sColOffset As Long = 1
    Const dName As String = "Sheet1"
    Const lFirst As String = "C2"
    Const dColOffset As Long = 1
    Const NF As String = "NOT FOUND"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim rg As Range
    Dim doExit As Boolean
    
    ' Source
    
    ' Define Source Lookup (Column) Range.
    Set rg = refColumn(wb.Worksheets(sName).Range(sFirst))
    If rg Is Nothing Then
        doExit = True
        GoTo ProcExit
    End If
    ' Write values from Source Lookup Range to Source Lookup Array.
    Dim sLookup As Variant: sLookup = getColumnFormula(rg)
    ' Write values from Source Data Range to Source Data Array.
    Dim sData As Variant: sData = getColumn(rg.Offset(, sColOffset))
    ' Determine Source Rows Count.
    Dim srCount As Long: srCount = UBound(sLookup, 1)
    
    ' Destination
    
    ' Define Destination Lookup (Column) Range.
    Set rg = Nothing
    Set rg = refColumn(wb.Worksheets(dName).Range(lFirst))
    If rg Is Nothing Then
        doExit = True
        GoTo ProcExit
    End If
    ' Write values from Destination Lookup Range to Destination Lookup Array.
    Dim dLookup As Variant: dLookup = getColumnFormula(rg)
    ' Determine Destination Rows Count.
    Dim drCount As Long: drCount = UBound(dLookup, 1)
    ' Define Destination Data (Column) Range.
    Set rg = rg.Offset(, dColOffset)
    ' Define Destination Data Array.
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
    
    ' Loop
    
    Dim cValue As Variant
    Dim cMatch As Variant
    Dim i As Long, k As Long
    For i = 1 To drCount
        cValue = dLookup(i, 1)
        If Not IsError(cValue) Then
            If Len(cValue) > 0 Then
                cMatch = Application.Match(cValue & "*", sLookup, 0)
                If IsNumeric(cMatch) Then
                    dData(i, 1) = sData(cMatch, 1)
                Else
                    For k = 1 To srCount
                        If LCase(cValue) Like LCase(sLookup(k, 1)) & "*" Then
                            dData(i, 1) = sData(k, 1)
                            Exit For
                        End If
                    Next k
                    If k > srCount Then
                        dData(i, 1) = NF
                    End If
                End If
            Else ' Len(cValue) = 0 (e.g. 'Empty', "'", =""...)
            End If
        Else ' 'cValue' contains an error value.
        End If
    Next i
    
    rg.Value = dData
    
ProcExit:
    If doExit = True Then
        MsgBox "Could not do it.", vbCritical, "Fail"
    Else
        MsgBox "Data transferred.", vbInformation, "Success"
    End If
        
    Exit Sub
clearError:
    doExit = True
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Sub

Function refColumn( _
    FirstCellRange As Range, _
    Optional ByVal NonBlankInsteadOfNonEmpty As Boolean = False) _
As Range
    Const ProcName As String = "refColumn"
    On Error GoTo clearError
    
    If Not FirstCellRange Is Nothing Then
        With FirstCellRange.Cells(1)
            Dim cLookIn As XlFindLookIn
            If NonBlankInsteadOfNonEmpty Then
                cLookIn = xlValues
            Else
                cLookIn = xlFormulas
            End If
            Dim cel As Range
            Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , cLookIn, , , xlPrevious)
            If Not cel Is Nothing Then
                Set refColumn = .Resize(cel.Row - .Row + 1)
            End If
        End With
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Function getColumn( _
    rg As Range, _
    Optional ByVal ColumnNumber As Long = 1, _
    Optional ByVal doTranspose As Boolean = False) _
As Variant
    Const ProcName As String = "getColumn"
    On Error GoTo clearError
    
    If Not rg Is Nothing Then
        If ColumnNumber > 0 And ColumnNumber <= rg.Columns.Count Then
            With rg.Columns(ColumnNumber)
                Dim rCount As Long: rCount = rg.Rows.Count
                Dim Result As Variant
                If rCount > 1 Then
                    If doTranspose Then
                        Dim Data As Variant: Data = .Value
                        ReDim Result(1 To 1, 1 To rCount)
                        Dim r As Long
                        For r = 1 To rCount
                            Result(1, r) = Data(r, 1)
                        Next r
                        getColumn = Result
                    Else
                        getColumn = .Value
                    End If
                Else
                    ReDim Result(1 To 1, 1 To 1): Result(1, 1) = .Value
                    getColumn = Result
                End If
            End With
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Function getColumnFormula( _
    rg As Range, _
    Optional ByVal ColumnNumber As Long = 1, _
    Optional ByVal doTranspose As Boolean = False) _
As Variant
    Const ProcName As String = "getColumnFormula"
    On Error GoTo clearError
    
    If Not rg Is Nothing Then
        If ColumnNumber > 0 And ColumnNumber <= rg.Columns.Count Then
            With rg.Columns(ColumnNumber)
                Dim rCount As Long: rCount = rg.Rows.Count
                Dim Result As Variant
                If rCount > 1 Then
                    If doTranspose Then
                        Dim Data As Variant: Data = .Formula
                        ReDim Result(1 To 1, 1 To rCount)
                        Dim r As Long
                        For r = 1 To rCount
                            Result(1, r) = Data(r, 1)
                        Next r
                        getColumnFormula = Result
                    Else
                        getColumnFormula = .Formula
                    End If
                Else
                    ReDim Result(1 To 1, 1 To 1): Result(1, 1) = .Formula
                    getColumnFormula = Result
                End If
            End With
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function