Question

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

首先，我们使用原始数据制作Excel文件。从源中提取时，此原始数据始终包含收集的所有数据，甚至包含我们之前收集的数据。有九列，每列有两个单独的变量。列A具有主题编号，以下列包含与该主题相关的数据（因此，列A到I的一行数据与一个主题的数据相关）。一旦我们在excel文件中有原始数据，我们就需要将所有数据池中的新数据移动到一系列主电子表格中，这些电子表格根据不同的响应者和时间点分开。我希望能够找到一种方法来将每个主电子表格单独地与原始数据Excel文件进行比较，以突出显示先前传输的任何数据行。这样可以更轻松地将新数据移动到主电子表格中。

有什么想法吗？请随意问我是否有需要进一步澄清的事情。谢谢 - 阿德里安娜

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

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

它会比较结果的两种颜色和颜色。

<强> SETUP：

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

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

DatabaseB：要比较的第二个数据库的全部内容

类似：这将获取两者在COMMON

中的所有记录

UniqueA：这些行只出现在dbA

中

UniqueB：仅出现在dbB

中

ConflictA：两个冲突页面都是相同的记录，其中一些条目缺失，另一条填写。冲突A突出显示“ORANGE”中缺少B但存在于A中的单元格，而“RED”则表示两个数据库中存在但具有不同值的值。

ConflictB：与ConflictA相同，但单元格为“BLUE”

ConflictResolution：这会收集来自ConflictA＆amp;的所有记录。 B并将它们合并到可能的位置。即，类似的匹配记录与一个数据库中存在的某些值，而不是另一个数据库。

ConflictDoubles：提供两个数据库中存在的记录的报告，并且需要进行评估，因为这些值存在冲突。有人需要选择他们的大脑。

所有这些工作表都是空的，除了标题行以匹配数据库A＆amp; B.将数据复制到这两张纸中。（所有表格中的相同栏目布局）

<强> TESTED

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的示例突出显示在一个版本中没有冲突但在另一个版本中没有冲突的单元格。
的冲突A

<强>冲突B

解决冲突

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

2 个答案: