比较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

我认为您的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

添加了红色。

---

可能更快的版本将使用数组和字典：

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

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

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