Проблема с Excel VBA Script (ссылка на ветку в сообщении)

Question

Я работаю над написанием сценария VBA для объединения строк, если идентификатор совпадает, а затем суммирования информации в нескольких полях и, наконец, удаления нижней строки, чтобы у меня была только одна запись для каждого идентификатора.

Отсечение экрана данных, с которыми я работаю. Строки 13 и 14 являются примером тех, которые должны быть объединены.

Пример данных скриншота

Я основал свой сценарий на ответе Raystafarian (последняя редакция) в приведенных ниже вопросах и ответах:

Как объединить значения из нескольких строк в одну строку в Excel?

Мой сценарий:

Sub mergeSumDelete()
Dim lastRow As Long
Dim myCell As Range

'lastRow = Cells(Rows.Count, "A").End(x1Up).Row

'Alternate way of trying to find the last row since I was having issues with the above
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each myCell In Range(Cells("A2"), Cells(lastRow, 1))
    If (myCell = myCell.Offset(1)) And (myCell.Offset(0, 1) = myCell.Offset(1, 1)) Then
        'Add up the data from the matching cells and put it in the top cell
        myCell.Offset(0, 2) = myCell.Offset(0, 2) + myCell.Offset(1, 2)
        myCell.Offset(0, 3) = myCell.Offset(0, 3) + myCell.Offset(1, 3)
        myCell.Offset(0, 4) = myCell.Offset(0, 4) + myCell.Offset(1, 4)

        'Delete the bottom row after data is merged
        myCell.Offset(1).EntireRow.Delete
    End If
Next
End Sub

Вот мои проблемы, которые у меня возникают.

1. Для строки, которая присваивает lastRow значение, я получаю ошибку Runtime 1004. Не уверен, что здесь происходит. Я попытался сделать это по-другому, а затем столкнулся с другой ошибкой ...

2. Я нашел альтернативный способ присвоить lastRow значение, которое, казалось бы, работает (или, по крайней мере, не выдало ошибку ...) Теперь я получаю сообщение об ошибке для каждого оператора, ошибка времени выполнения 5 (недопустимый вызов процедуры или аргумент).

Answer 1

Мне удалось найти решение / написать лучший сценарий.

• Размеры выбора на основе потребностей для моих целей
• Проходит выделение и пытается найти строки с повторяющимися значениями в столбцах A. (В моем случае это были идентификаторы транспортных средств)
• Если он находит совпадение, то он суммирует значения для B, C, D со значениями B, C, D в соответствующей строке идентификатора ниже
• Удалить дубликат строки (строка ниже текущей строки)
• Повторяет этот цикл 3 раза в случае, если есть до 4 дубликатов (мои данные позволили это; я пробовал динамическое решение, но не смог. Подсказки?)
• Изменяет размер выделения для удаления посторонних строк с нулевыми значениями

Любые отзывы приветствуются, особенно как сделать их динамическими для неизвестного числа дубликатов.

Sub dataClean()
'Calls the below subs

Call compareSumDelete_v3
Call deleteZeroRows

End Sub

Sub compareSumDelete_v3()

'OPTIMIZATIONS ---------------------------------------------------------
With Application
    .ScreenUpdating = False
'END OPTIMIZATIONS -----------------------------------------------------

'DYNAMICALLY SELECTING THE RANGE TO WORK WITH --------------------------
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim startCell As Range

    Set sht = ActiveWorkbook.ActiveSheet
    Set startCell = Range("A2")

    'Refresh UsedRange
    ActiveWorkbook.ActiveSheet.UsedRange

    'Find Last Row
    lastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    'Select Range
    sht.Range("A2:D" & lastRow - 3).Select
'END OF SELECTING THE RANGE ---------------------------------------------

'COMPARING "A" CELL VALUES, SUMMING IF MATCH, DELETING OLD ENTRY --------
    Dim i As Long
    Dim j As Integer

    'Loop through three times in case there are up to 4 duplicate entries, will combine all 4 with 3 iterations
    For j = 1 To 3
        For i = 1 To Selection.Rows.Count Step 1
            If Selection.Rows(i).Columns("A") = Selection.Rows(i + 1).Columns("A") Then
                Selection.Rows(i).Columns("B") = Selection.Rows(i).Columns("B") + Selection.Rows(i + 1).Columns("B")
                Selection.Rows(i).Columns("C") = Selection.Rows(i).Columns("C") + Selection.Rows(i + 1).Columns("C")
                Selection.Rows(i).Columns("D") = Selection.Rows(i).Columns("D") + Selection.Rows(i + 1).Columns("D")

                Selection.Rows(i + 1).EntireRow.Delete

            End If
        Next i
    Next j
'END COMPARING/SUMMING/DELETING -----------------------------------------

End With

End Sub

Sub deleteZeroRows()

With Application
    .ScreenUpdating = False
    .Calculation = x1calculationmanual

'DYNAMICALLY SELECTING THE RANGE TO WORK WITH --------------------------
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim startCell As Range

    Set sht = ActiveWorkbook.ActiveSheet
    Set startCell = Range("B2")

    'Refresh UsedRange
    ActiveWorkbook.ActiveSheet.UsedRange

    'Find Last Row
    lastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    'Select Range
    sht.Range("B2:B" & lastRow).Select
'END OF SELECTING THE RANGE ---------------------------------------------

    Dim i As Long

    For i = Selection.Rows.Count To 1 Step -1
        If Selection.Rows(i) = 0 Then
            Selection.Rows(i).EntireRow.Delete
        End If
    Next i

End With
End Sub