Сравните 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 вместо тега ": (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, но в долгосрочной перспективе рекомендуется работать с типом данных словаря , так как он оптимизирован для хранения уникальных значений.Таким образом, как только вы найдете способ передачи данных ячеек в словарь, это способ добавить пропущенные значения от 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

В конце все уникальные значения находятся в наборе B:

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