Compare 2 ranges add new items to end of range

Question

I have a range in column D and a range in column F. These ranges contain strings, the strings in column D are unique (i.e. they do not repeat) and the strings in column F are also unique. However, column D and F should both contain the same strings most of the time, although they may be in a different order. The strings look something similar to:

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

Sometimes column D may be missing some of the strings or it may have some new strings. I want to compare column D to column F and if there are new strings in column D, I want to add (append) them to the end of column F. Here is a simple Example using simply a,b,c instead of "tag:(00... bla... bla...":

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

Column D is missing "d" but has "a" and "f"... so "a" and "f" will be added (apended) to the end to column F, like this:

Column F
b
c
d
e
g
a
f

I was trying to use this as a less direct route but I can't even get this to work:

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

My thinking was: If I could get the new strings into column G... then delete the blank spaces then copy and paste them appending them to the end of column F... but it seems to just identify that the last item in column D is "g" and the last item in column F is blank and it would pull a "g" out of the list even though it already had a "g"...

When I originally found this code it had:

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

it didn't work so I changed it to:

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

Your `r` is shared as is, so you need a separate row count for column F as `r` is logically used to loop column D. So `cells(r,7) needs a different variable for `r` Out of interest, why not just replace F with D's values? — Nathan_Sav, Feb 19 '19 at 13:59
Isn't the problem this line `Cells(r, 7) = Cells(r, 4)`? The 7 and 4 can't be hardcoded can they? — SJR, Feb 19 '19 at 13:59
A quicker way might be to loop through both building a dictionary of unique items and then copy the dictionary contents to both columns. — SJR, Feb 19 '19 at 14:00
@ Nathan... I thought that question might come up... as I indicated, I can't simply replace F with D's values because D may be missing some values that are in F and D may be in a different order... It is important that they order and contents of F are maintained and new values are simply added to the end... Thanks for everyone's quick input... give me a minutes to digest/try your solutions... — XCELLGUY, Feb 19 '19 at 14:11

Pᴇʜ · Answer 1 · 2019-02-19T14:53:01.483

I think your CountIf was looking in the wrong column.

I recommend the following approach:

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

The red ones were added.

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

score 1 · Answer 2 · answered Feb 19 '19 at 14:17

This could be a bit overkill for Excel development, but in the long run, it is a good idea to work with Dictionary data type, as it is optimized to store unique values. Thus, once you find a way to pass the cells data to a dictionary, this is a way to add the missing values of setA to 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

And these are the additional functions:

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

At the end, all the unique values are at setB:

I had wondered if there was a way to do this using something like a dictionary. But I had no idea how to go about it and your code is over my head at the moment. One thing I am not clear about is... it looks like you are manually adding each item. Which is not that big of a task in my example where there were only a few items in each range. But in reality my ranges contain hundreds of rows of strings. — XCELLGUY, Feb 19 '19 at 16:15
@XCELLGUY - the code is adding manually, in order to introduce the values better and to make a [mcve]. Otherwise, a for-each loop with `Add` within or automatically getting the range values to array and then to a list is a viable option - https://stackoverflow.com/questions/37689847/creating-an-array-from-a-range-in-vba — Vityata, Feb 19 '19 at 16:24

score 0 · Accepted Answer · answered Feb 19 '19 at 14:01

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

Compare 2 ranges add new items to end of range

3 Answers3

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