Question

标题不是很好，所以这里有解释。

我需要将A列中的单元格值与B列匹配，以查找B列中缺少的单元格值。问题是可能存在重复值。即，A列有两个“橙色”，B列有一个“橙色”。在这种情况下，缺少一个“橙色”。

我会在C列中写下缺失值。

我的方法是尝试创建一个valuse形式的列A的集合。对集合和删除运行列B的值是匹配的。然后将剩余的值写入C列。

然而，正如您所知，集合无法处理重复值。

我考虑使用数组但是从数组中删除单元格似乎并不是我所见过的简单事项。

我的限制是我无法对excel文件中的数据进行任何更改。即删除数据或为匹配的单元格添加颜色等，这意味着我无法以方便的方式标记匹配的一次。

我没有使用字典的经验，或者它是否有任何解决方案，但我不确定这是一个可行的方法，因为它需要检查引用。我不认为将数据复制到第二个excel表是正确的方法，因为这可能会破坏计算机上正在发生的其他事情。

问题很简单，有什么替代方案？如果不是我将不得不使用我已经拥有的工具进行解决。但如果有一种方法我还没有找到......

这是我写的收集方法。

    Sub Test()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim cell As Range
    Dim rng As Range

    Dim colec As Collection

    Set colec = New Collection

    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet

    Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(5, 1))

     For Each cell In rng.Cells

        If ExistsInCollection(colec, CStr(cell.Value)) = False Then

            On Error Resume Next
            colec.Add cell.Value, CStr(cell.Value) 'Adds the first selected range to collection
            On Error GoTo 0

        Else

            colec.Add cell.Value

        End If

    Next cell

    Set rng = ws.Range(ws.Cells(1, 2), ws.Cells(4, 2))

    For Each cell In rng.Cells

            On Error Resume Next
            colec.Remove (CStr(cell.Value))
            On Error GoTo 0

    Next cell
End Sub

这是我复制的函数，用于检查集合中是否已存在值。

'Copied from outside source
Private Function ExistsInCollection(pColl, ByVal pKey As String) As Boolean
    On Error GoTo NoSuchKey
    If VarType(pColl.Item(pKey)) = vbObject Then
         ' force an error condition if key does not exist
    End If
    ExistsInCollection = True
    Exit Function

NoSuchKey:
    ExistsInCollection = False
End Function

请告诉我是否需要澄清任何事情。

感谢您提供任何帮助！

/亨里克

Answer 1

正如蒂姆·威廉姆斯所说，使用词典。

下面是您修改的代码，使用Dictionary而不是Collection（以及其他一些更改，例如将结果写入C列）。

Sub Test()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim cell As Range
    Dim rng As Range
    Dim key As Variant
    Dim i As Integer
    Dim r As Integer
    Dim lastRow As Long
    Dim dictValues As New Dictionary

    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet

    With ws
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        Set rng = .Range(.Cells(1, 1), .Cells(lastRow, 1))

        For Each cell In rng.Cells
            If dictValues.Exists(CStr(cell.Value)) Then
                dictValues(CStr(cell.Value)) = dictValues(CStr(cell.Value)) + 1
            Else
                dictValues(CStr(cell.Value)) = 1
            End If
        Next cell

        Set rng = .Range(.Cells(1, 2), .Cells(lastRow, 2))

        For Each cell In rng.Cells
            If dictValues.Exists(CStr(cell.Value)) Then
                dictValues(CStr(cell.Value)) = dictValues(CStr(cell.Value)) - 1
            End If
        Next cell

        r = 0
        For Each key In dictValues.Keys
            For i = 1 To dictValues(key)
                r = r + 1
                .Cells(r, 3).Value = key
            Next
        Next
    End With
End Sub

但是，如果你真的，真的，真的不想使用对Scripting对象的引用，这里是一个不使用Dictionary的版本：

Type ValueAndCount
    strValue As String
    intCount As Integer
End Type

Sub Test()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim cell As Range
    Dim rng As Range
    Dim i As Integer
    Dim r As Integer
    Dim p As Integer
    Dim lastRow As Long
    Dim colec() As ValueAndCount

    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet

    ReDim colec(0) As ValueAndCount
    With ws
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        Set rng = .Range(.Cells(1, 1), .Cells(lastRow, 1))

        For Each cell In rng.Cells
            p = LocationInCollection(colec, CStr(cell.Value))
            If p = 0 Then
                p = UBound(colec) + 1
                ReDim Preserve colec(p) As ValueAndCount
                colec(p).strValue = CStr(cell.Value)
                colec(p).intCount = 0
            End If
            colec(p).intCount = colec(p).intCount + 1
        Next cell

        Set rng = .Range(.Cells(1, 2), .Cells(lastRow, 2))

        For Each cell In rng.Cells
            p = LocationInCollection(colec, CStr(cell.Value))
            If p > 0 Then
                colec(p).intCount = colec(p).intCount - 1
            End If
        Next cell

        r = 0
        For p = 1 To UBound(colec)
            For i = 1 To colec(p).intCount
                r = r + 1
                .Cells(r, 3).Value = colec(p).strValue
            Next
        Next
    End With
End Sub

Private Function LocationInCollection(pColl() As ValueAndCount, ByVal pKey As String) As Integer
    Dim p As Integer
    For p = 1 To UBound(pColl)
        If pColl(p).strValue = pKey Then
            LocationInCollection = p
            Exit Function
        End If
    Next
    LocationInCollection = 0
End Function

Answer 2

这是我的另一个答案的完全不同的方法，基于OP的评论，结果将被写入C列（意味着C列可以用作临时工作区）：

Sub Test()
    Dim lastRow As Integer
    Dim rng As Range
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & lastRow).Copy Destination:=.Range("C1:C" & lastRow)
        For Each cell In .Range("B1:B" & lastRow)
            Set rng = .Range("C1:C" & lastRow).Find(cell.Value)
            If Not rng Is Nothing Then
                rng.Delete shift:=xlUp
            End If
        Next
    End With
End Sub

匹配单元格值并补偿重复项

2 个答案: