用于比较两组数据和 ID 排列的 Excel VBA 脚本

Posted 2023-02-25

【中文标题】用于比较两组数据和 ID 排列的 Excel VBA 脚本

【英文标题】：Excel VBA script to Compare Two Sets of Data and ID Permutations

【发布时间】：2014-02-12 21:51:52

【问题描述】：

我正在编写一个 VBA 脚本，它比较两列数据（每列大约 15,000 行）并确定是否有任何单元格是另一个单元格的排列/。

例如，如果 A1 = 15091 和 B52 = 19510，则该函数会将它们识别为具有相同的字符集。

我设置了一个循环，用于检查 A 列中的每个单独的单元格与 B 列中的每个其他单元格以及循环中的各种函数，但到目前为止，在完成此任务的任何事情上都没有成功。

此外，由于“数字”格式的单元格将在小数点后全部删除零，因此问题变得更加复杂，因此 15091.1 不会被识别为与 15091.01 相同的字符集。

【问题讨论】：

将所有单元格格式化为文本似乎是一个不错的起点。然后发布您现有的代码。

【参考方案1】：

您可以在没有 VBA 的情况下使用纯 Excel 方法来执行此操作。 （尽管找到下面的 VBA 解决方案）这个想法是为每个值构建一种“散列值”，对于一组数字的每个排列都是相同的 - 不与其他散列重叠。

这样做是为了：

计算 0-9 的每个数字的个数（例如 15091 和 19510 将是 1x0、2x1、1x5 和 1x9） 将每个计数乘以 10^digit（例如 1*10^0=1、2*10^1=20、1*10^5=100000、1x10^9=1000000000） 对这些产品求和，（例如 1000100021）

然后，您需要做的就是将这些哈希相互匹配（使用 Excel 的 MATCH 函数）并查看是否找到了某些东西（使用 ISERROR 函数）。

Excel的分步说明（假设您的数据在Sheet1和Sheet2的A列，从A1开始：

在 Sheet1 中： 在顶部插入两行 在 B3 中，放置此公式 =TEXT(A3,"0") - 这将消除每个数字的余数并将其转换为文本。将公式复制到范围的末尾 在 C1:L1 中，放置数字 0、1、2、... 在 C2:L2 中，放置公式 =10^C1 在 C3 中，放置此公式：=LEN($B3)-LEN(SUBSTITUTE($B3,C$1,"")) - 并将其复制到右侧直到列 L 并向下复制到列表末尾。这将计算位数 在 M3 中，放置这个公式：=SUMPRODUCT(C3:L3,$C$2:$L$2) - 这将计算哈希 在 Sheet2 中重复步骤 2-7 在 Sheet1 中，将此公式放入 N3：=NOT(ISERROR(MATCH(M3,Sheet2!$M:$M,0)))

完成！

这是一个 VBA 解决方案：

Option Explicit

Sub IdentifyMatches()
    Dim rngKeys As Range, rngToMatch As Range, rngCell As Range
    Dim dicHashes As Object
    'the range you want to have highlighted in case of a match
    Set rngKeys = Sheets("Sheet1").Range("A3:A5")

    'the range to search for matches
    Set rngToMatch = Sheets("Sheet2").Range("A3:A5")

    Set dicHashes = CreateObject("Scripting.Dictionary")

    'Create dictionary of hashes (dictionary is used for its .Exists property
    For Each rngCell In rngToMatch
        dicHashes(GetHash(rngCell)) = True
    Next

    'Check each cell in rngKey if it has a match
    For Each rngCell In rngKeys
        If dicHashes.Exists(GetHash(rngCell)) Then
            'Action to take in case of a match
            rngCell.Font.Bold = True
            Debug.Print rngCell.Value & " has a match!"
        Else
            rngCell.Font.Bold = False
        End If
    Next

End Sub


Function GetHash(rngValue As Range) As Long
    Dim strValue As String
    Dim i As Integer, digit As Integer
    Dim result As Long
    Dim digits(0 To 9) As Integer

    'Potentially add error check here
    strValue = Format(rngValue.Value, "0")

    For i = 1 To Len(strValue)
        digit = Int(Mid(strValue, i, 1))
        digits(digit) = digits(digit) + 1
    Next i

    For i = 0 To 9
        result = result + 10 ^ i * digits(i)
    Next i

    GetHash = result
End Function

最后但同样重要的是，here's the example file。

【讨论】：

一个有点像哈希表——太棒了。那是我什至没有想到的事情......我继续实施了非 vba 版本，该版本完美运行，但有 1 个异常。由于有 15k + 单元格，因此存在多个哈希重叠，并且该方法没有识别哪些单元格与相应的单元格重叠。因此，我所做的是创建了一个简单的循环，将每个匹配的单元格（我的 95% 的数据至少有 1 个匹配项）存储在一个数组中，并在相应的行中输出重叠的 cell.addresses 数组。通过添加一些过滤器，我设法将所有内容整理出来。感谢您的帮助！