Excel VBA - 将 LIST 中的值附加到每日变化的数据上

Question

Problem to solve for:

Sheet1 in my workbook refreshes daily. Column B in Sheet1 populates several rows with Account Names (and account names can have multiple rows).

I want Sheet2 Column A in my workbook to populate a distinct list of distinct accounts from Column B in Sheet1, WITH THE CATCH being, I want this to continuously append as Sheet1 will populate a new list of Accounts daily. In other words, if there are 5 accounts today, and 2 accounts tomorrow, I want Sheet 2 Column A to show all 7 Accounts.

I've scraped together some code from other posts that I thought would do this, but it's not populating anything in Sheet2. Please see the attached image and code below:

data format

Code:

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("Sheet1")
    Set LookupWks = ThisWorkbook.Worksheets("Sheet2")
    
    Set Dict = CreateObject("Scripting.Dictionary")
        Dict.CompareMode = vbTextCompare
        
        For r = 2 To MstrWks.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

I've done quite a bit of research on this topic, and hacked together some code from other posts and tweaks that I had seen, but it's not populating anything.

Answer 1

The problem is your code is only looking at the populated cells in sheet 2, so it stops before it ever gets to the keys that don't exist on that sheet.

If we iterate the dictionary instead of the cells and use find it will populate your sheet 2 with the missing keys:

Dim Cell        As Range
Dim key         As Variant ' I changed this to variant to use it as an iterator later on
Dim Dict        As Object
Dim LookupWks   As Worksheet
Dim MstrWks     As Worksheet
Dim NextCell    As Range
Dim r           As Long

    Set MstrWks = ThisWorkbook.Worksheets("Sheet1")
    Set LookupWks = ThisWorkbook.Worksheets("Sheet2")
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
' Don't forget to add a sheet reference to Rows.Count, it may give the wrong value
    For r = 2 To MstrWks.Cells(MstrWks.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
    Dim findrng As Range
    With LookupWks
        r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        For Each key In Dict
            Set findrng = .Range("A:A").Find(key, .Cells(2, 1), xlValues, xlWhole, xlByRows, xlNext)
            If findrng Is Nothing Then
                .Cells(r, 1).Value = key
                r = r + 1
            End If
        Next key
    End With

Answer 2

I've put together some modifications to your code that should hopefully get you moving in the right direction. I've embedded comments directly into the code to give you an idea of what's happening. Let me know if it helps.

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
    Dim DestDict    As Object
    Set MstrWks = ThisWorkbook.Worksheets("Sheet1")
    Set LookupWks = ThisWorkbook.Worksheets("Sheet2")
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
        
    'This is good. It establishes a dictionary of uniques from Master sheet
    For r = 2 To MstrWks.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
    
    ''''
    ' I might actually create another dictionary here against Sheet2
    ' This would contain uniques from Sheet 2 so that we don't add
    ' an element that is already here. This dict will contain items
    ' that are in sheet2. You can also likely use a Match function
    ' to check if items in the original dict are in this sheet.
    '''
    Set DestDict = CreateObject("scripting.dictionary")
    
    For r = 2 To LookupWks.Cells(Rows.Count, "A").End(xlUp).Row
        Key = LookupWks.Cells(r, "A")
        If Trim(Key) <> "" Then
            If Not DestDict.exists(Key) Then
                DestDict.Add Key, r
            End If
        End If
    Next r
    
    '''''
    ' Now you have a dictionary with uniques from sheet1 and sheet 2
    ' Loop through the Sheet1 dict and add to sheet2 if the item
    ' is not in sheet2
    '''''
    Set NextCell = LookupWks.Cells(LookupWks.Rows.Count, "A").End(xlUp).Offset(1, 0)
    
    For Each oKey In Dict.Keys
        If Not DestDict.exists(oKey) Then
            NextCell.Value = oKey
            Set NextCell = NextCell.Offset(1)
        End If
    Next oKey
    
End Sub