时间戳

首页 > 解决方案 > 如何应用具有> 255 个字符的值的 Application.Match？

excel - 如何应用具有> 255 个字符的值的 Application.Match？

问题描述

我遍历两张表（OLD，NEW）以确定另一张中不存在哪些值。
这些值并不总是相同的顺序，因此我无法逐行检查。我搜索以查看是否存在值。

以下需要很长时间才能运行。（01:50 分钟，我的测试范围。）

Sub LOOPING()
'-------------------------------------------------------------------
Dim StartTime As Double
StartTime = Timer
'-------------------------------------------------------------------
Dim rngNEW As Range
Set rngNEW = Sheets("NEW").Range("D1:D6734")
Dim rngOLD As Range
Set rngOLD = Sheets("OLD").Range("D1:D6734")

a = ""
For Each item In rngNEW
    For Each item2 In rngOLD
        If item = item2 Then
            GoTo NextIter
        End If
    Next item2
    a = a & "," & item.Row
NextIter:
Next item

MsgBox a
'-------------------------------------------------------------------
MsgBox "RunTime : " & Format((Timer - StartTime) / 86400, "hh:mm:ss")
'-------------------------------------------------------------------
End Sub

以下运行速度很快，但没有返回任何内容（00:02 min 具有相同的测试范围。）
我发现 match 函数不适用于大于 255 个字符的单元格值。某些单元格值超过 3000 个字符。

Sub MATCHING()
'-------------------------------------------------------------------
Dim StartTime As Double
StartTime = Timer
'-------------------------------------------------------------------
Dim rngNEW As Range
Set rngNEW = Sheets("NEW").Range("D1:D6734")
Dim rngOLD As Range
Set rngOLD = Sheets("OLD").Range("D1:D6734")

a = ""
For Each item In rngNEW
    If IsError(Application.Match(item, rngOLD, 0)) Then
        a = a & "," & item.Row
    End If
Next item
MsgBox a
'-------------------------------------------------------------------
MsgBox "RunTime : " & Format((Timer - StartTime) / 86400, "hh:mm:ss")
'-------------------------------------------------------------------
End Sub

有没有办法克服 255 个字符的限制？

标签： excelvba

解决方案

如果您有必要的 dotNet 组件，那么这可能对您有用。它本质上使用SHA1将文本散列成一个 40 字节的字符串，并将其存储为字典键，用于新旧之间的比较。有关 SHA1 子程序，请参见此处。

Option Explicit

Sub LOOPING()
    '-------------------------------------------------------------------
    Dim StartTime As Double
    StartTime = Timer
    '-------------------------------------------------------------------
    
    Const COL = "D"
    Const LASTROW = 6734
    Dim wsNEW As Worksheet, wsOLD As Worksheet, wsDebug As Worksheet
    Dim i As Long, n As Long
    Dim key As String, msg As String, s As String
    Dim dictOLD As Object, dictNEW As Object

    With ThisWorkbook
       Set wsNEW = .Sheets("NEW")
       Set wsOLD = .Sheets("OLD")
       Set wsDebug = .Sheets("DEBUG")
    End With
    wsDebug.Cells.Clear
    wsDebug.Range("A1:D1") = Array("NEW Row", "NEW Value", "OLD Row", "OLD Value")
    n = 2

    ' build dictionary with SHA1 digests as keys
    Set dictOLD = CreateObject("Scripting.Dictionary")
    For i = 1 To LASTROW
        key = Trim(wsOLD.Cells(i, COL))
        If Len(key) > 0 Then
            key = SHA1(key)
            dictOLD(key) = i
        End If
    Next

    ' scan NEW for items not in OLD
    msg = "NEW not in OLD:"
    Set dictNEW = CreateObject("Scripting.Dictionary")
    For i = 1 To LASTROW
        s = Trim(wsNEW.Cells(i, COL))
        If Len(s) > 0 Then
            key = SHA1(s)
            If Not dictOLD.exists(key) Then
                msg = msg & "," & i
                wsDebug.Cells(n, 1) = i
                wsDebug.Cells(n, 2) = s
                wsDebug.Cells(n, 3) = "No match"
                n = n + 1
            End If
            dictNEW(key) = i
        End If
    Next

   ' scan OLD for items not is NEW
    msg = msg & vbCr & "OLD not in NEW:"
    For i = 1 To LASTROW
        s = Trim(wsOLD.Cells(i, COL))
        If Len(s) > 0 Then
            key = SHA1(s)
            If Not dictNEW.exists(key) Then
                msg = msg & "," & i
                wsDebug.Cells(n, 1) = "No Match"
                wsDebug.Cells(n, 3) = i
                wsDebug.Cells(n, 4) = s
                n = n + 1
            End If
        End If
    Next

    MsgBox msg, vbInformation, "No Match"
    '-------------------------------------------------------------------
    MsgBox "RunTime : " & Format((Timer - StartTime) / 86400, "hh:mm:ss")
    '-------------------------------------------------------------------
End Sub

Public Function SHA1(ByVal s As String) As String
    Dim Enc As Object, Prov As Object
    Dim Hash() As Byte, i As Integer

    Set Enc = CreateObject("System.Text.UTF8Encoding")
    Set Prov = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")

    Hash = Prov.ComputeHash_2(Enc.GetBytes_4(s))

    SHA1 = ""
    For i = LBound(Hash) To UBound(Hash)
        SHA1 = SHA1 & Hex(Hash(i) \ 16) & Hex(Hash(i) Mod 16)
    Next
End Function

推荐阅读