Удаление дубликатов при перемещении на другой лист - VBA

Формулировка задачи:

Доброго времени суток, есть макрос, который удаляет дубликаты и переносит их на другой лист, но нужно добавить еще одно условие, в столбце O идут разные услуги, нужно, чтобы макрос добавлял только те даты на другой лист, если в столбце O стоит услуга "Выезд". Иначе даты дублируются, если в один день оказано больше одной услуги. Не могли бы, пожалуйста, поправить этот момент?

Решение задачи: «Удаление дубликатов при перемещении на другой лист»

textual
                            Листинг программы 
                        

                            Sub Объединить_дубликаты()
 
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arr(), lr As Long, i As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    shSrc.Columns("F:G").Copy shRes.Columns("A:B")
    shSrc.Columns("K:L").Copy shRes.Columns("C:D")
    shSrc.Columns("J").Copy shRes.Columns("E")
    shSrc.Columns("B").Copy shRes.Columns("F")
    shSrc.Columns("O").Copy shRes.Columns("G")
    
    rw = shRes.Range("G" & Rows.Count).End(xlUp).Row
    
    For i = 2 To rw
    If shRes.Range("G" & i) = "" Then Exit For
    If shRes.Range("G" & i) <> "Выезд" Then shRes.Rows(i).Delete Shift:=xlUp: i = i - 1
    Next i
    
    
    MergeAddress shRes
    shRes.Columns("D").Delete
    
    shRes.Sort.SortFields.Add Key:=shRes.Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending
    shRes.Sort.SortFields.Add Key:=shRes.Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending
    shRes.Sort.SortFields.Add Key:=shRes.Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending
    With shRes.Sort
        .SetRange shRes.Columns("A:E")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    arr() = shRes.Range("A1:E" & lr).Value
    For i = UBound(arr) To 3 Step -1
        If arr(i, 1) = arr(i - 1, 1) And arr(i, 2) = arr(i - 1, 2) Then
            arr(i - 1, 3) = arr(i, 3)
            arr(i - 1, 4) = arr(i, 4)
            arr(i - 1, 5) = arr(i - 1, 5) & Chr(10) & arr(i, 5)
            arr(i, 1) = Empty
        End If
    Next i
    
    shRes.Range("A1:E" & lr).Value = arr()
    
    On Error Resume Next
    shRes.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    shRes.Columns("A:E").HorizontalAlignment = xlCenter
    shRes.Columns("A:E").VerticalAlignment = xlCenter
    
    Application.ScreenUpdating = True
 
End Sub
 
Private Sub MergeAddress(shRes As Worksheet)
 
    Dim arr1(), arr2(), lr As Long, i As Long
    
    lr = shRes.Columns("C:D").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    arr1() = shRes.Range("C2:D" & lr).Value
    ReDim arr2(1 To UBound(arr1), 1 To 1)
    
    For i = 1 To UBound(arr1)
        arr2(i, 1) = arr1(i, 1) & ", " & arr1(i, 2)
    Next i
    shRes.Range("C2").Resize(UBound(arr2)).Value = arr2()
 
End Sub
                        