Question

我希望你能提供帮助。我有一段代码，它的工作原理相对较好。

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

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

图1

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

您可以在图2中看到重复项已合并，并且保留了最早开始日期和最晚结束日期的一行数据

AgnholtJørgenSteen是正确的

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

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

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

VBA代码没有合并所有重复项

1 个答案: