セルの値を一致させ、重複を補償してください

Question

見出しはあまりよくありませんのでここで説明します。

列Aから列Bのセル値を一致させて、列Bから欠落しているセル値を見つける必要があります。 重複する値がある可能性があるという問題があります。 I列Aは2つの「オレンジ」を有し、列Bは1つの「オレンジ」を有する。この場合、1つの「オレンジ」が欠落しています。

私は私のアプローチは、コレクションに対してvaluseフォーム列A.実行列Bの値のコレクションを作成しようと、削除することであったコラムC.

、let'sが言うに欠損値を書き込みます。一致がありますか？その後、残りの値を列Cに書き込みます。

しかし、あなたが知っているように、コレクションは重複値を処理できません。

私は配列を使っていると考えましたが、配列から細胞を削除することは、私が見ただけの単純なものではないようです。

私の制限は、Excelファイルにあるデータを変更できないということです。私はデータを削除したり、マッチしたセルなどに色を付けたりします。これは、一度マッチしたalreayを便利な方法でマークすることはできません。

私は辞書を使った経験がありませんが、これには何らかの解決策がありますが、参照をチェックする必要があるため、これは実用的なアプローチではないと私は確信しています。 データを2番目の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

これは完全に異なっています

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