[英]Find Values from Workbook1, Column1 that are unique from values in Workbook2, Column 1 and display in new sheet
我想显示在 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
根据您在上面提供的示例数据,您的数据似乎在多个帐户 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
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.