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

Question

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

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

我会写的，let's说，列C.

我的做法一直是缺失值，试图创建valuse形式A列中润B列的值的集合对收集和删除有一场比赛。然后将其余值写入C列。

但是，正如您可能知道集合无法处理重复值。

我认为使用数组，但从数组中删除单元格似乎不是我所见过的简单事情。

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

我没有使用字典的经验，或者如果它有任何解决方案，但我不确定这是一种可行的方法，因为它需要检查参考。 我不认为将数据复制到第二张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 

请告诉我，如果我必须澄清任何事情。

我很感谢您提供的任何帮助！

/Henrik

Answer 1

这是一个完全不同的方法我其他的答案的基础上，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 

Answer 2

正如Tim Williams所说，使用Dictionary。

下面是您的代码修改为使用字典而不是集合（以及一些其他更改，如将结果写入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 

但是，如果你真的，真的，真的不希望使用该脚本对象的引用，这里是一个版本，不使用词典：

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