匹配單元格值並補償重複項

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