Excel宏，帮助识别重复的数据行

Question

我想知道是否有人有任何关于编写宏的信息，以帮助比较可能包含相同值列表的两组数据。事情是这样的：

首先，我们用原始数据制作Excel文件。这些原始数据，当从源中提取时，总是包含所有收集的数据，甚至包括我们之前收集的数据。有九列，每列关联两个单独的变量。列A具有主题编号，下面的列包含与该主题相关的数据(因此，A到I列中的一行数据属于一个主题的数据)。一旦我们有了excel文件中的原始数据，我们需要将所有数据池中的新数据移动到一系列主电子表格中，这些主电子表格根据不同的受访者和时间点而分开。我希望能够找到一种方法，将每个主电子表格分别与原始数据Excel文件进行比较，以突出显示以前传输的任何数据行。这将使将新数据移动到主电子表格中变得更加容易。

有什么想法吗？如果有什么需要进一步澄清的，请随时问我。谢谢- Adrienne

Answer 1

您可以使用条件格式来突出显示重复项(如此处所述：http://www.excel-easy.com/examples/find-duplicates.html)，或使用VBA宏，如下面的代码片段所示：

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，

Answer 2

这样做的概念是，有两个具有相同结构的数据库，需要比较和分析匹配、差异、冲突等。当它完成运行时，您可以查看为评估冲突并解决它们而创建的工作表。在此阶段，您可以在做出一些决定后手动复制一些行。繁重的任务在代码中。

它将对两者进行比较并对结果进行颜色格式化。

设置：

您需要设置以下工作表:并手动复制标题行

DatabaseA:要比较的第一个数据库的全部内容

DatabaseB:第二个数据库的全部内容以进行比较

相似：这将获取两者共有的所有记录

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

​

​

ConflictB

​

​

冲突解决方案

​

​