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

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

这对于 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:

比较 2 个范围将新项目添加到范围末尾

Compare 2 ranges add new items to end of range

excel

vba

for-loop

string-comparison

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