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
CodePudding user response：
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
tmpstris a missing variable. It's best to useOption Explicit Statementto find this issue.NWS.Cells(Rng.Row, 1).Value = tmpstrneeds to have the cell formatted totextbefore applying this. This can be done withNWS.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
CodePudding user response：
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