从 Workbook1、Column1 中查找与 Workbook2、Column 1 中的值不同的值并在新工作表中显示

Question

I want to display the values found in Column 1 of workbook1 that are not in column 1 of workbook2. I am treating the contents as strings for exact match. Some of the account numbers look alike, but are not because they have leading 0's that make it different.

Workbook1: Column I am referencing is "AccountID"

AccountID
001  
002  
003  
4  
5  
6  
7  
8  
9  
10  

Workbook 2 column I am referencing is "AccountID"

AccountID  
1  
2  
3    
5  
6  
7  
8  

Desired Result Unique values from workbook1 that are not in workbook2 put into a new sheet

AccountID  
001   
002  
003  
4  
9   
10  

here is my code, but some of the returned values ARE in both workbooks. I want the values from Workbook1, column1 that are unique from values in Workbook2, columnn1.

    'Method to show what AccountID is in Client Bill Info but not  FDG Accounts.
Sub CompareCols()
    'Disabling the screen updating.
    Application.ScreenUpdating = False
    
    'Declaring variables
    Dim Rng As Range
    Dim RngList As Object
    Dim WB1 As Worksheet
    Dim WB2 As Worksheet
    Dim NWS As Worksheet
    
    'Setting values to variables declared
    Set WB1 = ThisWorkbook.Sheets("Detailed Bill Info")
    Set WB2 = Workbooks("FDG Accounts.xlsx").Sheets("FDG Accounts")
    Set RngList = CreateObject("Scripting.Dictionary")
    Set NWS = Sheets.Add
    
    'Loop to collect values that are in column A of this workbook
    'that are not in column A of WB2
    For Each Rng In WB2.Range("A2", WB2.Range("A" & Rows.Count).End(xlUp))
        If Not RngList.Exists(CStr(Rng.Value)) Then
            RngList.Add CStr(Rng.Value), Nothing
        End If
    Next
    For Each Rng In WB1.Range("A2", WB1.Range("A" & Rows.Count).End(xlUp))
        If Not RngList.Exists(CStr(Rng.Value)) Then
            WB1.Cells(Rng.Row, 1).Interior.ColorIndex = 6
            tmpstr = Rng.Value
            NWS.Cells(Rng.Row, 1).Value = tmpstr
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

Extra Characters

Based on the sample data you provided above it appears that your data contains extra white space on several Account Id's.

To fix this, use the Trim function to remove the white space. Make sure to do this when checking to see if the value exists in your dictionary, as well as when you are capturing the value as well.

Extra notes

• tmpstr is a missing variable. It's best to use Option Explicit Statement to find this issue.
• NWS.Cells(Rng.Row, 1).Value = tmpstr needs to have the cell formatted to text before applying this. This can be done with NWS.Cells(Rng.Row, 1).NumberFormat = "@"

The fix

Below is your code with the above changes:

' Method to show what AccountID is in Client Bill Info but not  FDG Accounts.
Sub CompareCols()
    'Disabling the screen updating.
    Application.ScreenUpdating = False
    
    'Declaring variables
    Dim Rng As Range
    Dim RngList As Object
    Dim WB1 As Worksheet
    Dim WB2 As Worksheet
    Dim NWS As Worksheet
    
    'Setting values to variables declared
    Set WB1 = ThisWorkbook.Sheets("Detailed Bill Info")
    Set WB2 = Workbooks("FDG Accounts.xlsx").Sheets("FDG Accounts")
    
    Set RngList = CreateObject("Scripting.Dictionary")
    Set NWS = Sheets.Add
    
    'Loop to collect values that are in column A of this workbook
    'that are not in column A of WB2
    For Each Rng In WB2.Range("A2", WB2.Range("A" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Trim(CStr(Rng.Value))) Then
            RngList.Add Trim(CStr(Rng.Value)), Nothing
        End If
    Next
    For Each Rng In WB1.Range("A2", WB1.Range("A" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Trim(CStr(Rng.Value))) Then
            WB1.Cells(Rng.Row, 1).Interior.ColorIndex = 6
            
            Dim tmpstr As String ' Added Missing variable
            tmpstr = Trim(Rng.Value)
            
            ' Format will be lost on new cell
            ' Make sure to update it to text before
            ' setting the value
            NWS.Cells(Rng.Row, 1).NumberFormat = "@"
            NWS.Cells(Rng.Row, 1).Value = tmpstr
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Answer 2

Unique Strings in Dictionaries

Option Explicit

Sub IdentifyNewAccounts()

    Const NewName As String = "New Accounts"

    ' Reference the source column range ('srg').
    Dim swb As Workbook: Set swb = Workbooks("FDG Accounts.xlsx")
    Dim sws As Worksheet: Set sws = swb.Worksheets("FDG Accounts")
    Dim srg As Range
    Set srg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    ' Write the unique values from the source column range
    ' to the keys of the source dictionary ('sDict').

    Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
    sDict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim sCell As Range
    Dim sString As String
    
    For Each sCell In srg.Cells
        sString = CStr(sCell.Value)
        If Len(sString) > 0 Then ' exclude blanks
            sDict(sString) = Empty
        End If
    Next sCell
    
    ' Reference the destination column range ('drg').
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets("Detailed Bill Info")
    Dim drg As Range
    Set drg = dws.Range("A2", dws.Cells(dws.Rows.Count, "A").End(xlUp))
    
    ' Write the unique values from the destination column range,
    ' that are not in the 'keys' of the source dictionary, to the 'keys'
    ' of the destination dictionary ('dDict').
    
    Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
    dDict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim durg As Range
    Dim dCell As Range
    Dim dString As String
    
    For Each dCell In drg.Cells
        dString = CStr(dCell.Value)
        If Len(dString) > 0 Then ' the cell is not blank
            If Not sDict.Exists(dString) Then ' not found in source dictionary
                ' Write the unique string to the destination dictionary.
                dDict(dString) = Empty
                ' Combine the cells to be highlighted into a range union.
                If durg Is Nothing Then ' first cell
                    Set durg = dCell
                Else ' all but the first cell
                    Set durg = Union(durg, dCell)
                End If
            'Else ' the string was found in the source dictionary; do nothing
            End If
        'Else ' the cell is blank; do nothing
        End If
    Next dCell
    Set sDict = Nothing ' the relevant data is in the destination dictionary
    
    ' Validate.
    If durg Is Nothing Then ' or 'If dDict.Count = 0 Then'
        MsgBox "No unique accounts found.", vbExclamation
        Exit Sub
    End If
    
    ' Write the unique strings from the destination dictionary to the
    ' destination array ('dData'), a 2D one-based one-column string array.
    
    Dim drCount As Long: drCount = dDict.Count
    Dim dData() As String: ReDim dData(1 To drCount, 1 To 1)
    
    Dim dKey As Variant
    Dim r As Long
    
    For Each dKey In dDict.Keys
        r = r + 1
        dData(r, 1) = dKey
    Next dKey
    Set dDict = Nothing ' the relevant data is in the destination array
    
    ' Turn off screen updating (so far the worksheets were only read from).
    Application.ScreenUpdating = False
    
    ' Highlight the cells meeting the criteria in one go.
    durg.Interior.Color = vbYellow
           
    ' Add a new worksheet, the new destination worksheet ('ndws').
    
    Dim ndws As Worksheet
    ' Attempt to reference it.
    On Error Resume Next
        Set ndws = dwb.Worksheets(NewName)
    On Error GoTo 0
    ' Check if it was referenced (if it exists).
    If Not ndws Is Nothing Then ' it exists
        Application.DisplayAlerts = False ' to delete without confirmation
            ndws.Delete
        Application.DisplayAlerts = True
    'Else ' it doesn't exist; do nothing
    End If
    ' Add and reference it.
    Set ndws = dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count))
    ' Apply changes.
    With ndws
        .Name = NewName ' rename
        .Range("A1").Value = "AccountID" ' write header
    End With
    
    ' Reference the new destination (one-column) data range ('dnrg').
    Dim ndrg As Range: Set ndrg = ndws.Range("A2").Resize(drCount)
    
    ' Write the unique strings from the destination array
    ' to the new destination range.
    With ndrg
        .NumberFormat = "@" ' format
        .Value = dData ' write
        .EntireColumn.AutoFit ' more format
    End With
    
    ' Activate (select) the destination workbook.
    If Not dwb Is ActiveWorkbook Then ' it's not active
        dwb.Activate
    'Else ' it's already active; do nothing 
    End If
    
    ' Save the destination workbook.
    'dwb.Save

    ' Turn on screen updating (to see the changes behind the message box).
    Application.ScreenUpdating = True

    ' Inform.
    MsgBox "New accounts identified.", vbInformation

End Sub