Код VBA не объединяет все дубликаты

Question

Надеюсь, вы сможете помочь. У меня есть код, и он работает относительно хорошо.

Что он делает, это позволяет пользователю щелкнуть по командной кнопке, которая откроет диалоговое окно. Затем пользователь выбирает другой лист excel, затем код идентифицирует дубликаты, объединяет эти дубликаты, создавая новую строку данных с самой ранней доступной датой начала и последней доступной датой окончания, а затем удаляет дубликаты

Итак, на Рисунке 1 вы можете увидеть выбранный лист имеет повторяющиеся записи и несколько дат начала и окончания для этих повторяющихся записей

Pic 1

Рис 2 показывает лист после того, как код выполняется

Вы можете увидеть в Pic 2, дубли были объединены и ряд данных с самой ранней датой начала и последней датой окончания осталось

Agnholt Йорген Стина правильно

Андерсен Андерса Nyboe правильно

Но это работает только в том случае, дубли непосредственно под Афоризм, если они не являются, как и в случае с

Chr istensen 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

Ваш код удаляет дубликаты, которые один за другим. Эти дубликаты не касаются, поэтому их не удаляют. Этот способ работы выполняется быстрее (линейный, а не квадратичный, как обычный дублирующий код поиска), но не работает, если некоторые дубликаты не касаются)

Решение. Вам следует отсортировать таблицу (относительно всех столбцов, а не только первый) перед запуском кода. Таким образом, дубликаты всегда будут касаться.