比较2个范围将新项目添加到范围结束

Question

我在列D中有一个范围，在列F中有一个范围。这些范围包含字符串，列D中的字符串是唯一的（即它们不重复），列F中的字符串也是唯一的。但是，D列和F列在大多数情况下都应包含相同的字符串，尽管它们的顺序可能不同。字符串看起来类似于：

tag:(0004)X-axis
tag:(0005)Z-axis
tag:(0005)X-axis
tag:(0006)Z-axis

有时列D可能缺少一些字符串，或者它可能有一些新的字符串。我想将列D与列F进行比较，如果列D中有新字符串，我想将它们添加（追加）到列F的末尾。这是一个简单的示例，只使用a，b，c而不是“tag” ：（00 ...... bla ... bla ......“：

Column D    Column F
a           b
b           c
c           d
e           e
f           g
g

D列缺少“d”但是有“a”和“f”......所以“a”和“f”将被添加（附加）到F列的末尾，如下所示：

Column F
b
c
d
e
g
a
f

我试图用这个作为一个不太直接的路线，但我甚至无法让它工作：

Sub RT_COMPILER()

Dim Lastrow As Long
Dim r As Long
Dim n As Long

For r = 1 To Lastrow
    n = Application.WorksheetFunction.CountIf(Range("D:D"), Cells(r, 6))
    If n = 0 Then
        Cells(r, 7) = Cells(r, 4)
    Else
        Cells(r, 7) = ""
    End If
Next

End Sub

我的想法是：如果我可以将新字符串放入列G ...然后删除空格，然后复制并粘贴它们将它们附加到列F的末尾...但它似乎只是识别列中的最后一项D是“g”，F列中的最后一项是空白的，即使它已经有一个“g”，它也会从列表中拉出“g”...

当我最初发现这个代码时，它有：

n = Application.WorksheetFunction.CountIf("D:D", Cells(r, 6))

它不起作用所以我改为：

n = Application.WorksheetFunction.CountIf(Range("D:D"), Cells(r, 6))

Answer 1

Option Explicit

Sub test()

    Dim LastrowD As Long, i As Long, LastrowF As Long, Times As Long
    Dim cell As Range, rngToSearch As Range
    Dim str As String

    With ThisWorkbook.Worksheets("Sheet5")

        LastrowD = .Cells(.Rows.Count, "D").End(xlUp).Row

        For i = 1 To LastrowD

            str = .Range("D" & i).Value
            LastrowF = .Cells(.Rows.Count, "F").End(xlUp).Row

            Set rngToSearch = .Range("F1:F" & LastrowF)

            Times = Application.WorksheetFunction.CountIf(rngToSearch, str)

            If Times = 0 Then
                .Range("F" & LastrowF + 1) = str
            End If

        Next i

    End With

End Sub

Answer 2

对于Excel开发来说这可能有点过分，但从长远来看，使用Dictionary data type是一个好主意，因为它经过优化以存储唯一值。因此，一旦找到将单元格数据传递到字典的方法，就可以将setA的缺失值添加到setB：

Sub TestMe()

    Dim setA As Object
    Dim setB As Object        
    Set setA = CreateObject("Scripting.Dictionary")
    Set setB = CreateObject("Scripting.Dictionary")

    AddToDictionaryIfNotPresent "A", setA
    AddToDictionaryIfNotPresent "B", setA
    AddToDictionaryIfNotPresent "C", setA
    AddToDictionaryIfNotPresent "D", setA        
    AddToDictionaryIfNotPresent "A", setB
    AddToDictionaryIfNotPresent "B", setB
    AddToDictionaryIfNotPresent "A", setB   'C is missing!
    AddToDictionaryIfNotPresent "D", setB

    Dim var As Variant
    For Each var In setA
        If Not ValueExistsInCollection(var, setB) Then
            Debug.Print "Adding "; var
            AddToDictionaryIfNotPresent var, setB
        End If
    Next

End Sub

这些是附加功能：

Public Function AddToDictionaryIfNotPresent(myValue As Variant, myDictionary As Object)

    If Not myDictionary.Exists(myValue) Then myDictionary.Add myValue, 1

End Function

Public Function ValueExistsInCollection(myValue As Variant, myDictionary As Object) As Boolean

    Dim var As Variant        
    For Each var In myDictionary
        If var = myValue Then
            ValueExistsInCollection = True
            Exit Function
        End If
    Next var

End Function

最后，所有唯一值都在setB：

Answer 3

我认为你的CountIf正在寻找错误的专栏。

我推荐以下方法：

Option Explicit

Public Sub CompareAndAppend()
    Dim ws As Worksheet 'define worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    Dim NextFreeRow As Long
    NextFreeRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row + 1

    Dim cnt As Long

    Dim iRow As Long
    For iRow = 1 To LastRow 'loop through column D
        cnt = Application.WorksheetFunction.CountIf(ws.Range("F:F"), ws.Cells(iRow, "D"))
        If cnt = 0 Then 'this value is missing in F, append it
            ws.Cells(NextFreeRow, "F").Value = ws.Cells(iRow, "D")
            NextFreeRow = NextFreeRow + 1 'move to next free row
        End If
    Next iRow
End Sub

红色的是添加。

---

A probably faster version would be using arrays and a dictionary:

Public Sub CompareAndAppendSpeedyGonzales()
    Dim ws As Worksheet 'define worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim InputArr() As Variant
    InputArr = ws.Range("D1", ws.Cells(ws.Rows.Count, "D").End(xlUp)).Value

    Dim CompareArr() As Variant
    CompareArr = ws.Range("F1", ws.Cells(ws.Rows.Count, "F").End(xlUp)).Value

    Dim AppendArr As Variant

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim i As Long
    'add column F
    For i = LBound(CompareArr, 1) To UBound(CompareArr, 1)
        If Not dict.exists(CompareArr(i, 1)) Then
            dict.Add CompareArr(i, 1), 0
        End If
    Next i

    'add column D
    For i = LBound(InputArr, 1) To UBound(InputArr, 1)
        If Not dict.exists(InputArr(i, 1)) Then
            dict.Add InputArr(i, 1), 0
            If IsEmpty(AppendArr) Then
                ReDim AppendArr(1 To 1)
                AppendArr(1) = InputArr(i, 1)
            Else
                ReDim Preserve AppendArr(1 To UBound(AppendArr) + 1)
                AppendArr(UBound(AppendArr)) = InputArr(i, 1)
            End If
        End If
    Next i

    ws.Cells(ws.Rows.Count, "F").End(xlUp).Offset(1, 0).Resize(RowSize:=UBound(AppendArr)).Value = Application.WorksheetFunction.Transpose(AppendArr)
End Sub