数字与列表之间的复杂相似匹配
Complex similar match between number against a list
我想在数字列表中找到更相似的数字。 A 列是一些数字，B 列是该数字的相关代码。
在 C 列中是我想为其找到最相似值的条目，并在可能的情况下将输出放在显示相关产品的 D 列中。我希望有道理。
我用颜色显示每个条目更相似的“短代码”。
我的拙劣尝试如下所示，我使用 Index 和 Match 来查找完全匹配，但是对于最接近的匹配我不知道如何开始。
我喜欢使用 VBA 来实现这一点，因为我会将其应用于不是列中的值，而是 vba 数组中的值。
Sub GestClosestMatch()
Set wf = WorksheetFunction
ExactMatch = wf.Index(Range("B2:B15"), Application.Match(Range("C12"), Range("A2:A15"), 0))
ClosestMatch = ?
End Sub
我在 this thread 中测试了 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 | |
+------------+---------+-----------+
更新
如果我以前像这样在数组中加载数据：
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
数组的结构是这样的，输出在 EntriesArr 的第 3 个“列”中：
试试这个：
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:$A;$C2) 并向下填充到范围内的最后一行。
注意：需要时用,替换;。
这应该return:
现在，您可以在 E 列中使用 VLookup 公式 ;)
随时根据您的需要改进上述功能。例如，如果您替换
retVal = c.Value
和
retVal = c.Offset(ColumnOffset:=1).Value
您将获得一个产品名称。
[编辑]
改进版本 - 根据 OP 的评论。注意：您不能在下面的代码中使用 Range.Offset() 函数。您必须在另一列中使用 VLookup 函数。
'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
双向部分匹配
代码
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
我想在数字列表中找到更相似的数字。 A 列是一些数字，B 列是该数字的相关代码。 在 C 列中是我想为其找到最相似值的条目，并在可能的情况下将输出放在显示相关产品的 D 列中。我希望有道理。
我用颜色显示每个条目更相似的“短代码”。
我的拙劣尝试如下所示，我使用 Index 和 Match 来查找完全匹配，但是对于最接近的匹配我不知道如何开始。
我喜欢使用 VBA 来实现这一点，因为我会将其应用于不是列中的值，而是 vba 数组中的值。
Sub GestClosestMatch()
Set wf = WorksheetFunction
ExactMatch = wf.Index(Range("B2:B15"), Application.Match(Range("C12"), Range("A2:A15"), 0))
ClosestMatch = ?
End Sub
我在 this thread 中测试了 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 | |
+------------+---------+-----------+
更新
如果我以前像这样在数组中加载数据：
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
数组的结构是这样的，输出在 EntriesArr 的第 3 个“列”中：
试试这个：
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:$A;$C2) 并向下填充到范围内的最后一行。
注意：需要时用,替换;。
这应该return:
现在，您可以在 E 列中使用 VLookup 公式 ;)
随时根据您的需要改进上述功能。例如，如果您替换
retVal = c.Value
和
retVal = c.Offset(ColumnOffset:=1).Value
您将获得一个产品名称。
[编辑]
改进版本 - 根据 OP 的评论。注意：您不能在下面的代码中使用 Range.Offset() 函数。您必须在另一列中使用 VLookup 函数。
'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
双向部分匹配
代码
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