Vba 阵列和对齐之间的部分匹配

我正在使用单个大型excel电子表格（数百万个数据点）。在第一列中，我有大约2500个六位数的识别号。在第二种情况下，我有大约70000个11位数的识别号。每6位ID包含在11位ID中的一位（例如，单元格A79中的701190将与单元格B41520中的490070190X相关）。我想做的是创建一个函数（或VBA代码），该函数标识部分匹配，并高亮显示、着色或重新对齐第二个数组，以使匹配可见。我在用

=MATCH("*"&LEFT(A2,5)&"*",B2:B29,0)

这在C列中给了我一个输出，告诉我正确的单元格，但这需要花费大量的时间，大约2500次。以下是数据的示例：

Column A   Column B 
152028     2810152006 
152032     4900152010    
152033     4900152028 
152006     380152013X 
152007     4900152033
152008     4900152007 
152010     4801152032 
152013     290152008X

如果仔细观察，您会发现A中包含的所有ID都在B中的ID中找到，但不是在任何固定位置，也不是在模式中。实际数据远比这更混乱

---

您有什么建议可以帮助您轻松识别B列中哪些ID代表a列中的ID吗

使用“间接”和“地址”的组合，使用现有匹配行将完整ID提取到C列：

您已找到与的行

=匹配（“*”&左（A2,5）和“*”，B2:B29,0）

现在使用它来获取带有

address

的完整单元格地址，具体使用2列B：

=地址（匹配（“*”&左（A2,5）和“*”，B2:B29,0），2）

使用“间接”将其包装以获取单元格中包含的实际值：

---

=INDIRECT（地址（匹配（“*”&左（A2,5）和“*”，B2:B29,0），2））

这可能有些过分，但如果您需要将部分匹配的11位ID转换为6位ID，那么运行下面这样的SQL查询应该可以轻松获得所需的结果

Sub Partial()

    Dim con As Object
    Dim rec As Object
    Dim sCon As String, dataSource As String, sql As String

    '/* path of the target workbook, take note of the semi-colon */
    dataSource = ThisWorkbook.FullName & ";"
    '/* this is simply the connection string found on the link below */
    sCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & dataSource & _
           "Extended Properties = ""Excel 12.0;HDR=NO"";"

    Set con = CreateObject("ADODB.Connection")
    con.Open sCon
    '/* Sheet1 is where your data is, change to suit */
    '/* F1 is for Field 1 corresponding to column A, F1 - columnB and so on */
    sql = "SELECT a.[F1], b.[F2] FROM [Sheet1$] a "
    sql = sql & "INNER JOIN [Sheet1$] b ON b.[F2] LIKE '%' & a.[F1] & '%';"

    Set rec = CreateObject("ADODB.Recordset")
    rec.Open sql, con, 3, 1

    If Not rec.BOF And Not rec.EOF Then
        '/* Sheet2 is where your data should go, change to suit */
        Sheets("Sheet2").Range("A1").CopyFromRecordset rec
    End If

    rec.Close: con.Close
    Set rec = Nothing: Set con = Nothing

End Sub

因此，表1中的数据如下：

将复制到Sheet2中，如下所示（按您的要求重新排列）：

我使用的是和

.xlsb

文件，如果您使用的是

.xlsm

（或

.xls

用于较低版本的Excel），则可以更改。您也可以在单独的工作簿中运行此操作，只需将

数据源

更改为目标工作簿的路径即可

dataSoure = "C:\User\User.Name\MyExcel.xlsx"

---

你可以用简单的VBA来实现。我不确定在您所述大小的数据库上需要多长时间，因为对于a列中的每个项目，它必须循环遍历B列中的每个项目，或者2500*70000个操作。在我的模拟样品上，在我的电脑上，完成任务只花了三（3）分钟

它将把A列中的项目放入C列，该项目位于B列中的项目中

通过在C列上过滤以排除空白，可以很容易地看到匹配项

如前所述，它不区分大小写

Option Explicit
Sub MatchWithin()
    Dim wsSrc As Worksheet, rRes As Range
    Dim vMatch As Variant, vWithin As Variant, vResults As Variant
    Dim I As Long, J As Long
    Dim sKey As String

Set wsSrc = Worksheets("sheet2")
With wsSrc
    vMatch = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value2
    vWithin = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value2
    ReDim vRes(1 To UBound(vWithin, 1), 1 To 1)
    Set rRes = .Cells(1, 3).Resize(rowsize:=UBound(vWithin, 1))
End With

For I = 1 To UBound(vMatch, 1)
    sKey = vMatch(I, 1)
    For J = 1 To UBound(vWithin, 1)
        If InStr(1, vWithin(J, 1), sKey, vbTextCompare) > 0 Then
            vRes(J, 1) = sKey
            Exit For
        End If
    Next J
Next I

'write the results

Application.ScreenUpdating = False
With rRes
    .EntireColumn.Clear
    .NumberFormat = "0"
    .Value = vRes
    .EntireColumn.ColumnWidth = 255 'so numbers don't get displayed as "#####"
    .EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

End Sub

---

如果速度是个问题，你真的不想为此创建函数。而是使用Instr函数编写一个子函数来标识匹配项：。将两张表读入一个数组以获得更好的性能。很可能使用VBA，但不是真正必要的-如果您可以将匹配的ID读入C列而不是匹配的行，请参见下面的答案为什么您只从ColA中选取前5个字符？是的，我认为@TimWilliams是正确的。你应该从

右边（A2,5）

？如果多个B列与单个a列匹配怎么办？我认为

索引

比

间接

更好。你能提供一个例子来代替我建议的吗？

索引（B$2:B$29，匹配（“*”&左（$A2,5）和“*”，B$2:B$29,0））

返回实际值。这为我做到了。一旦我有了完整ID的列表，我就能够排除空白以获得精确的匹配。所有这些都是为了拉一些特定人群的通过率@马多克医生很乐意帮忙。通过在

forj=…

循环中添加

Exit For

with，它可能会运行得更快，具体取决于您的布局。请参阅我的编辑。