VBA 代码未合并所有重复项

Question

希望你能帮上忙。我有一段代码，它工作得比较好。

它的作用是允许用户单击打开对话框的命令按钮。然后用户选择另一个 Excel 表，然后代码识别重复项合并这些重复项，创建具有最早可用开始日期和最晚可用结束日期的新数据行，然后删除重复项

因此，在图 1 中，您可以看到所选工作表具有重复条目以及这些重复条目的多个开始和结束日期

图 1

图2显示代码执行后的工作表

在图2中可以看到重复的已经合并，剩下一行最早开始日期和最晚结束日期的数据

Agnholt Jørgen Steen 是正确的

Andersen Anders Nyboe 是正确的

但只有当重复项与

不同时，它才有效

Christensen Tove 和 Christensen Trine Tang 我的代码无法识别重复项，并且无法合并或处理日期。

是否可以修改我的代码以解决重复项不在彼此下方的问题？

我的代码一如既往地在下面，非常感谢所有帮助。

我的代码

Sub Open_Workbook_Dialog()


    Dim strFileName     As String
    Dim wkb             As Workbook
    Dim wks             As Worksheet
    Dim lastRow         As Long
    Dim r               As Long

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        strFileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    Set wkb = Application.Workbooks.Open(strFileName)
    Set wks = ActiveWorkbook.Sheets(1)
    lastRow = wks.UsedRange.Rows.Count

    For r = lastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
           ' Update Start Date on Previous Row
        If CDate(wks.Cells(r, 8)) < CDate(wks.Cells(r - 1, 8)) Then
         wks.Cells(r - 1, 8) = wks.Cells(r, 8)
        End If
        ' Update End Date on Previous Row
        If CDate(wks.Cells(r, 9)) > CDate(wks.Cells(r - 1, 9)) Then
        wks.Cells(r - 1, 9) = wks.Cells(r, 9)
        End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

所以我修改了代码以对 B 列进行排序，但仍然存在重复项

添加了排序的我的代码再次在下方，非常感谢任何帮助。

代码

Sub Open_Workbook_Dialog()


    Dim strFileName     As String
    Dim wkb             As Workbook
    Dim wks             As Worksheet
    Dim lastRow         As Long
    Dim r               As Long

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        strFileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    Set wkb = Application.Workbooks.Open(strFileName)
    Set wks = ActiveWorkbook.Sheets(1)
    lastRow = wks.UsedRange.Rows.Count

With ActiveWorkbook.Sheets(1)

    .Unprotect
    lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    .Range("A1").Resize(79, lastcol).Sort Key1:=Range("B1"), _
    Order1:=xlAscending, _
    Header:=xlGuess, _
    OrderCustom:=1, _
    MatchCase:=False, _
    Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
End With

    For r = lastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
           ' Update Start Date on Previous Row
        If CDate(wks.Cells(r, 8)) < CDate(wks.Cells(r - 1, 8)) Then
         wks.Cells(r - 1, 8) = wks.Cells(r, 8)
        End If
        ' Update End Date on Previous Row
        If CDate(wks.Cells(r, 9)) > CDate(wks.Cells(r - 1, 9)) Then
        wks.Cells(r - 1, 9) = wks.Cells(r, 9)
        End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

Answer 1

您的代码会删除一个接一个的重复项。这些重复项不会触及，因此不会被删除。 这种方式更快（线性而不是像正常重复查找代码那样的二次方），但如果某些重复项不接触则不起作用）

解决方案：您应该在运行代码之前对表进行排序（关于所有列，而不仅仅是第一列）。这样，重复项将始终接触。