從 Workbook1、Column1 中查找與 Workbook2、Column 1 中的值不同的值並在新工作表中顯示

Question

我想顯示在 workbook1 的第 1 列中找到但不在 workbook2 的第 1 列中的值。 我將內容視為完全匹配的字符串。 一些帳號看起來很相似，但並不是因為它們有前導 0，所以它們不同。

Workbook1：我引用的列是“AccountID”

AccountID
001  
002  
003  
4  
5  
6  
7  
8  
9  
10  

我引用的工作簿 2 列是“AccountID”

AccountID  
1  
2  
3    
5  
6  
7  
8  

期望的結果 workbook1 中不在 workbook2 中的唯一值放入新工作表

AccountID  
001   
002  
003  
4  
9   
10  

這是我的代碼，但是兩個工作簿中都有一些返回值。 我想要 Workbook1，column1 中的值與 Workbook2，column1 中的值不同。

    '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

額外字符

根據您在上面提供的示例數據，您的數據似乎在多個帳戶 ID 上包含額外的空白。

要解決此問題，請使用Trim function 刪除空白。 確保在檢查字典中是否存在該值以及捕獲該值時執行此操作。

額外說明

• tmpstr是一個缺失變量。 最好使用Option Explicit Statement來查找此問題。
• NWS.Cells(Rng.Row, 1).Value = tmpstr需要在應用此之前將單元格格式化為text 。 這可以通過NWS.Cells(Rng.Row, 1).NumberFormat = "@"來完成

修復

以下是您的代碼進行了上述更改：

' 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

字典中的唯一字符串

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