我想知道是否有人有任何关于编写宏来帮助比较可能包含相同值列表的数据集的信息。这是交易：
首先，我们用原始数据制作 Excel 文件。从源中提取的原始数据始终包含所有收集的数据，甚至是我们之前收集的数据。有九列，每列涉及两个单独的变量。 A 列有主题编号，以下列包含与该主题有关的数据（因此，从 A 列到 I 列的一行数据与一个主题的数据有关）。一旦我们在 excel 文件中获得原始数据，我们需要将新数据从所有数据池中移动到一系列主电子表格中，这些电子表格根据不同的受访者和时间点分开。我希望能够找到一种方法将每个主电子表格分别与原始数据 Excel 文件进行比较，以突出显示之前传输的任何数据行。这样可以更轻松地将新数据移动到主电子表格中。
有什么想法吗？随时问我是否有需要更多澄清的事情。谢谢 - 阿德里安娜
【问题讨论】：
标签： excel
您可以使用条件格式来突出显示重复项（如下所述：http://www.excel-easy.com/examples/find-duplicates.html），或者使用 VBA 宏，如下面的代码 sn-p 所示：
Sub FindDups ()
'
' NOTE: You must select the first cell in the column and
' make sure that the column is sorted before running this macro
'
ScreenUpdating = False
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
Do While ActiveCell <> ""
If FirstItem = SecondItem Then
ActiveCell.Offset(Offsetcount,0).Interior.Color = RGB(255,0,0)
Offsetcount = Offsetcount + 1
SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
Else
ActiveCell.Offset(Offsetcount, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1,0).Value
Offsetcount = 1
End If
Loop
ScreenUpdating = True
End Sub
来源：http://support.microsoft.com/KB/213355
希望这会有所帮助。 Rgds，
【讨论】：
这个概念是有两个具有相同结构的数据库需要比较和分析匹配、差异、冲突等。当它完成运行后，您可以查看创建的工作表以评估冲突并解决他们。在那个阶段，您可以在做出一些决定后手动复制一些行。繁重的工作在代码中。
它将比较两者并对结果进行颜色格式化。
设置：
您需要设置以下工作表：并手动复制标题行
DatabaseA：第一个要比较的数据库的全部内容
DatabaseB：要比较的第二个数据库的全部内容
类似：这将获取两人在 COMMON 中的所有记录
UniqueA：这些是只出现在 dbA 中的行
UniqueB：只出现在dbB中
ConflictA： 两个冲突页面都是相同的记录，其中一个缺少一些条目，而另一个则已填写。冲突 A 突出显示 B 中缺少但存在于 A 中的“橙色”单元格，以及具有两个数据库中存在但具有不同值的值的“红色”单元格。
ConflictB：与 ConflictA 相同，只是单元格为“蓝色”
ConflictResolution： 这会从 ConflictA 和 B 中获取所有记录，并将它们合并到可能的位置。即，类似的匹配记录与某些值存在于一个数据库中，而不是在另一个数据库中。
ConflictDoubles：给出两个数据库中存在的记录的报告，并且需要评估，因为值是冲突的。有人需要用他们的大脑来选择。
除了与数据库 A 和 B 匹配的标题行之外，所有这些工作表都是空的。将您的数据复制到这两个工作表中。 （所有表格上的相同列布局）
测试
Sub DataMatch()
Dim lastRowA As Long
Dim lastRowB As Long
Dim lastRowUA As Long
Dim lastRowUB As Long
Dim lastRowSim As Long
Dim LastCol As Long
Dim lastRowCon As Long
Dim rng As Range
Dim matchCount As Integer
Dim sA As String
Dim sB As String
Dim uA As String
Dim uB As String
Dim sim As String
Dim conA As String
Dim conB As String
Dim rA As Integer
Dim rB As Integer
Dim rUA As Integer
Dim rUB As Integer
Dim rSim As Integer
Dim rCon As Integer
Dim tCol As Integer
Dim isConflict As Boolean
Dim ConflictListA() As Variant
Dim ConflictListB() As Variant
Dim isMatching As Boolean
'SET SHEET NAMES
sA = "DatabaseA"
sB = "DatabaseB"
sim = "Similar"
uA = "UniqueA"
uB = "UniqueB"
conA = "ConflictA"
conB = "ConflictB"
'Column B is the Key Column
lastRowA = Sheets(sA).Range("B" & Rows.Count).End(xlUp).Row
lastRowB = Sheets(sB).Range("B" & Rows.Count).End(xlUp).Row
lastRowUA = Sheets(uA).Range("B" & Rows.Count).End(xlUp).Row
lastRowUB = Sheets(uB).Range("B" & Rows.Count).End(xlUp).Row
lastRowSim = Sheets(sim).Range("B" & Rows.Count).End(xlUp).Row
LastCol = Sheets(sA).Cells(1, Columns.Count).End(xlToLeft).Column '114
'Set the First Row for the target sheets
rCon = 2
rSim = 2
rUA = 2
rUB = 2
'------------------------LOOP THROUGH SHEET A AND CHECK FOR UNIQUE ENTRIES------------------------'
Set rng = Sheets(sB).Range("B2:B" & lastRowB)
For rA = 2 To lastRowA
tKey = Sheets(sA).Cells(rA, 2)
matchCount = Application.WorksheetFunction.CountIf(rng, tKey)
'Check to see if there are any matches on SourceSheet2
If matchCount = 0 Then
'There are NO matches. Copy Entire Row to UniqueA
For x = 1 To LastCol
Sheets(uA).Cells(rUA, x) = Sheets(sA).Cells(rA, x)
Next x
rUA = rUA + 1
Else
'Get first matching occurance on the SourceSheet2
m = Application.WorksheetFunction.Match(tKey, rng, 0)
'Get Absolute Row number of that match
rB = m + 1 ' This takes into account the Header Row, as index 1 is Row 2 of the search Range
'Compare to make sure they are complete matches. If there is a conflict, send to Conflict Sheets
For tCol = 1 To LastCol
If Sheets(sA).Cells(rA, tCol) = Sheets(sB).Cells(rB, tCol) Then
isConflict = False
Else
isConflict = True
'Copy Data to ConflictA and ConflictB
For x = 1 To LastCol
Sheets(conA).Cells(rCon, x) = Sheets(sA).Cells(rA, x)
Sheets(conB).Cells(rCon, x) = Sheets(sB).Cells(rB, x)
Next x
rCon = rCon + 1
Exit For
End If
Next tCol
'Similar records, adding to Similar Sheet
If isConflict = False Then
For x = 1 To LastCol
Sheets(sim).Cells(rSim, x) = Sheets(sA).Cells(rA, x)
Next x
rSim = rSim + 1
End If
End If
Next rA
'------------------------LOOP THROUGH SHEET B AND CHECK FOR UNIQUE ENTRIES------------------------'
Set rng = Sheets(sA).Range("B2:B" & lastRowA)
For rB = 2 To lastRowB
tKey = Sheets(sB).Cells(rB, 2)
matchCount = Application.WorksheetFunction.CountIf(rng, tKey)
'Check to see if there are any matches on SourceSheet2
If matchCount = 0 Then
'There are NO matches. Copy Entire Row to UniqueB
For x = 1 To LastCol
Sheets(uB).Cells(rUB, x) = Sheets(sB).Cells(rB, x)
Next x
rUB = rUB + 1
End If
Next rB
Call HighlightDifference
End Sub
Private Sub HighlightDifference()
Dim LastRow As Integer
Dim LastCol As Integer
Dim ConflictRows() As String
Dim cDRow As Integer
Dim blDimensioned As Boolean
cDRow = 2
blDimensioned = False
LastRow = Sheets("ConflictA").Range("B" & Rows.Count).End(xlUp).Row
LastCol = Sheets("ConflictA").Cells(1, Columns.Count).End(xlToLeft).Column '114
For r = 2 To LastRow
For c = 1 To LastCol
If Sheets("ConflictA").Cells(r, c) <> Sheets("ConflictB").Cells(r, c) Then
Sheets("ConflictA").Cells(r, c).Interior.ColorIndex = 40
Sheets("ConflictB").Cells(r, c).Interior.ColorIndex = 37
If Sheets("ConflictA").Cells(r, c) <> "" And Sheets("ConflictB").Cells(r, c) <> "" Then
'MsgBox ("Both sheets have values in Cells.(" & r & ", " & c & ")" & vbNewLine & _
"Adding row to exception list to create new table")
Sheets("ConflictA").Cells(r, c).Interior.ColorIndex = 3
Sheets("ConflictB").Cells(r, c).Interior.ColorIndex = 3
Sheets("ConflictA").Cells(r, 2).Interior.ColorIndex = 3
Sheets("ConflictB").Cells(r, 2).Interior.ColorIndex = 3
'Sheets("ConflictResolution").Cells(r, c) = Sheets("ConflictA").Cells(r, c) & " / " & Sheets("ConflictB").Cells(r, c)
Sheets("ConflictResolution").Cells(r, c) = "CONFLICT"
Sheets("ConflictResolution").Cells(r, c).Interior.ColorIndex = 3
Sheets("ConflictResolution").Cells(r, 2).Interior.ColorIndex = 3
'Add the row of the Conflict Resolution Sheet to exceptions to Note later with Color
If blDimensioned = True Then
ReDim Preserve ConflictRows(0 To UBound(ConflictRows) + 1) As String
Else
ReDim ConflictRows(0 To 0) As String
blDimensioned = True
End If
ConflictRows(UBound(ConflictRows)) = r
'Add Separate Row for Each Source to ConflictDoubles
For cDCol = 1 To LastCol
Sheets("ConflictDoubles").Cells(cDRow, cDCol) = Sheets("ConflictA").Cells(r, cDCol)
Sheets("ConflictDoubles").Cells(cDRow, cDCol).Interior.ColorIndex = 40
Sheets("ConflictDoubles").Cells(cDRow + 1, cDCol) = Sheets("ConflictB").Cells(r, cDCol)
Sheets("ConflictDoubles").Cells(cDRow + 1, cDCol).Interior.ColorIndex = 37
Next cDCol
cDRow = cDRow + 2
End If
If Sheets("ConflictA").Cells(r, c) = "" Then
Sheets("ConflictResolution").Cells(r, c) = Sheets("ConflictB").Cells(r, c)
Sheets("ConflictResolution").Cells(r, c).Interior.ColorIndex = 37
ElseIf Sheets("ConflictB").Cells(r, c) = "" And Sheets("ConflictA").Cells(r, c) <> "" Then
Sheets("ConflictResolution").Cells(r, c) = Sheets("ConflictA").Cells(r, c)
Sheets("ConflictResolution").Cells(r, c).Interior.ColorIndex = 40
End If
ElseIf Sheets("ConflictA").Cells(r, c) = Sheets("ConflictB").Cells(r, c) Then
Sheets("ConflictResolution").Cells(r, c) = Sheets("ConflictA").Cells(r, c)
End If
Next c
Next r
Call ShowDoubles
End Sub
Private Sub ShowDoubles()
Dim LastRow As Integer
Dim LastCol As Integer
LastRow = Sheets("ConflictDoubles").Range("B" & Rows.Count).End(xlUp).Row
LastCol = Sheets("ConflictDoubles").Cells(1, Columns.Count).End(xlToLeft).Column '114
r = 2
Do While r <= LastRow
For c = 1 To LastCol
If Sheets("ConflictDoubles").Cells(r, c) <> Sheets("ConflictDoubles").Cells(r + 1, c) Then
Sheets("ConflictDoubles").Cells(r, c).Interior.ColorIndex = 3
Sheets("ConflictDoubles").Cells(r + 1, c).Interior.ColorIndex = 3
End If
Next c
r = r + 2
Loop
End Sub
ConflictA 示例突出显示存在冲突的单元格，这些冲突在一个版本中为空，而在另一个版本中不为空。
ConflictA
冲突B
冲突解决
【讨论】：