VBA Help - Append only Unique Values to List

[Johnny Thunder]

Hello All,

I am trying to build a piece of code that will append only new values to a Lookup Table and not sure the best way to achieve this.

My criteria:

Sheets(Master) - Updated Daily so will contain new ID's once a day
ID Location: Sheets(Master).Range("A2:A" & LastRow)

Sheets(Lookup) - Contains my Lookup Table - Column A has the Unique ID's, Column B contains a User Defined Variable or Name that they fill in.

So I need a method to Look at all ID's on the Master sheet and if a New ID Appears append the ID to column A on the Lookup Sheet.

 

[Leith Ross]

Hello Johnny Thunder,

This will compare the Lookup to the Master. If any entry on the Lookup sheet is not found on the Master then the entry is added to end of the list in column "A" on Lookup.

Sub TestMacro()


    Dim Cell        As Range
    Dim Key         As String
    Dim Dict        As Object
    Dim LookupWks   As Worksheet
    Dim MstrWks     As Worksheet
    Dim NextCell    As Range
    Dim r           As Long
    
        Set MstrWks = ThisWorkbook.Worksheets("Master")
        Set LookupWks = ThisWorkbook.Worksheets("Lookup")
        
        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For r = 2 To MasterWks.Cells(Rows.Count, "A").End(xlUp).Row
                Key = MstrWks.Cells(r, "A")
                If Trim(Key) <> "" Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, r
                    End If
                End If
            Next r
            
            Set NextCell = LookupWks.Cells(2, "A").End(xlUp).Offset(1, 0)
            
            For r = 2 To LookupWks.Cells(Rows.Count, "A").End(xlUp).Row
                Key = LookupWks.Cells(r, "A")
                If Trim(Key) <> "" Then
                    If Not Dict.Exists(Key) Then
                        NextCell.Value = Key
                        Set NextCell = NextCell.Offset(1, 0)
                    End If
                End If
            Next r
            
End Sub

 

[Johnny Thunder]

Darn,

That code looks great but I forgot to mention, I am unable to use the scripting dictionary. I should have been more clear, I apologize.

Is there a way to adapt this code to a non-scripting dictionary version? Reason for this is the Mac version of Excel 2016 doesn't support this feature or any Active X controls. I've been finding workarounds for almost all of my PC style code for the last 6 months but this is always one thing that hinders me.

I appreciate the help on this.

 

[Leith Ross]

Hello Johnny Thunder,

The workaround for a Mac is to use a Collection object instead of the Dictionary object. It is little more code but works just as fast. I will make the needed changes and post back with the updated code.

 

[Johnny Thunder]

Your the best! I really appreciate all the help. And I think I just learned something new. I had no idea about the Collection Object.

 

[Leith Ross]

Hello Johnny Thunder,

Here is the updated code using a Collection object.

Sub TestMacro2()


    Dim Key         As String
    Dim Item        As Variant
    Dim LookupWks   As Worksheet
    Dim MstrWks     As Worksheet
    Dim NextCell    As Range
    Dim r           As Long
    Dim Uniques     As New Collection
    
        Set MstrWks = ThisWorkbook.Worksheets("Master")
        Set LookupWks = ThisWorkbook.Worksheets("Lookup")
            
            For r = 2 To MasterWks.Cells(Rows.Count, "A").End(xlUp).Row
                Key = MstrWks.Cells(r, "A")
                If Trim(Key) <> "" Then
                    On Error Resume Next
                        Uniques.Add r, Key
                        ' // Entry already exists
                        If Err = 457 Then Err.Clear
                    On Error GoTo 0
                End If
            Next r
            
            Set NextCell = LookupWks.Cells(2, "A").End(xlUp).Offset(1, 0)
            
            For r = 2 To LookupWks.Cells(Rows.Count, "A").End(xlUp).Row
                Key = LookupWks.Cells(r, "A")
                If Trim(Key) <> "" Then
                    On Error Resume Next
                        Item = Uniques(Key)
                        ' // Entry does not exist
                        If Err = 5 Then
                            NextCell.Value = Key
                            Set NextCell = NextCell.Offset(1, 0)
                        End If
                    On Error GoTo 0
                End If
            Next r
            
End Sub

 

[Johnny Thunder]

HI Leith,

Thanks for the quick revision to the code.

I noticed a misspelling on this line "For r = 2 To MstrWks.Cells(Rows.Count, "A").End(xlUp).Row" that was causing the code not to run, once corrected the code runs but it is not bringing in the one unique ID that I manually deleted from the Lookup table to test the code? Am I doing something wrong here?

My Master has over 100 rows of values but with only 8 unique ID's (Several ID's are repeated per row) and my Lookup sheet currently only has 7 ID's (I deleted 1 manually) but the code doesn't bring in that value?

 

[Leith Ross]

Hello JT,

I will test the code on a workbook setup with data arranged like you have and be sure it is working before I post it.

 

[Johnny Thunder]

So I ran through the code and see that the second block of code which I am assuming is comparing the Dictionary items to the current list in the lookups sheet seems to only loop for as many items appear on the lookup table and does not loop for every Unique Value that is found on the Master Sheet. not sure how to correct this.

So for example: If there are 10 ID's on the Master Sheet, and 7 of those appear on the Lookup Sheet the Code seems to only look at those 7 ID's and skips looking at the remaining 3 new ID's, not sure why this happens but I think it may be because the second block of code only takes into account the values that were already on the lookup sheet and not the full population of ID's.

With all the above I still have no idea how to modify the code LOL.

 

[Leith Ross]

Hello JT,

This macro will compare Lookup to the Master. Entries on the Master that are missing from Lookup are appended to Lookup. I tested this on a workbook laid out as you described and it worked. I have also added some additional error handling in case something happens that is unexpected.

Here is the working code...

Sub TestMacro3()


    Dim answer      As Integer
    Dim Cell        As Range
    Dim Done        As Boolean
    Dim Key         As String
    Dim Item        As Variant
    Dim LookupWks   As Worksheet
    Dim MstrWks     As Worksheet
    Dim NextCell    As Range
    Dim r           As Long
    Dim Uniques     As New Collection
    
        Set MstrWks = ThisWorkbook.Worksheets("Master")
        Set LookupWks = ThisWorkbook.Worksheets("Lookup")
            
            For r = 2 To LookupWks.Cells(Rows.Count, "A").End(xlUp).Row
                Key = LookupWks.Cells(r, "A")
                Item = LookupWks.Cells(r, "B").Value
                If Trim(Key) <> "" Then
                    On Error Resume Next
                        Uniques.Add Item, Key
                        ' // Entry already exists
                        If Err = 457 Then
                            Err.Clear
                        Else
                            ' // Unexpected error occurred
                            GoSub ErrHandler
                        End If
                    On Error GoTo 0
                End If
            Next r
            
            Set NextCell = LookupWks.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            
            For r = 2 To MstrWks.Cells(Rows.Count, "A").End(xlUp).Row
                Key = MstrWks.Cells(r, "A")
                Item = MstrWks.Cells(r, "B")
                If Trim(Key) <> "" Then
                    On Error Resume Next
                        Item = Uniques(Key)
                        ' // Entry does not exist
                        If Err = 5 Then
                            NextCell.Value = Key
                            Set NextCell = NextCell.Offset(1, 0)
                        Else
                            GoSub ErrHandler
                        End If
                    On Error GoTo 0
                End If
            Next r


            Done = True


ErrHandler:
            If Err <> 0 Then
                MsgBox "Run-time error'" & Err.Number & "':" & vbLf & vbLf & Err.Description
                answer = MsgBox("Continue?", vbYesNo + vbDefaultButton2 + vbQuestion, "Unexpected Error")
                If answer = vbNo Then Exit Sub Else Return
            End If


            If Not Done Then Return
            
End Sub