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.

 

[Johnny Thunder]

That worked great, thanks!

 

[Leith Ross]

Hello JT,

You're welcome. Sorry that took so long. Gald I could help.

 

[hartsie]

HELP!

I am trying to modify the script to work with my sheet. I have two lists in the same sheet. Each is starting on row 4. The first list containing the new set of values is in column B and the list I want to update is in column D. When I run the script, it keeps placing the unique value in B2, then in B3, then it stops running.

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("Sheet3")
Set LookupWks = ThisWorkbook.Worksheets("Sheet3")

Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare

For r = 4 To MstrWks.Cells(Rows.Count, "d").End(xlUp).Row
Key = MstrWks.Cells(r, "d")
If Trim(Key) <> "" Then
If Not Dict.Exists(Key) Then
Dict.Add Key, r
End If
End If
Next r

Set NextCell = LookupWks.Cells(4, "b").End(xlUp).Offset(1, 0)

For r = 4 To LookupWks.Cells(Rows.Count, "b").End(xlUp).Row
Key = LookupWks.Cells(r, "b")
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