☰

Excel VBA 脚本问题（消息中的主题链接）

tag-icon • tag-icon microsoft-excel vba
Excel VBA 脚本问题（消息中的主题链接）

我正在编写一个 VBA 脚本，如果 ID 匹配则合并行，然后对几个字段中的信息求和，最后删除下行，这样每个 ID 只有一个条目。

我正在处理的数据的屏幕截图。第 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 分配值的行，我收到运行时 1004 错误。不确定这里发生了什么。我尝试以不同的方式执行此操作，然后遇到另一个错误...

  2. 我找到了另一种为 lastRow 分配值的方法，这种方法似乎可行（或者至少没有引发错误。。）现在，我在使用 For each 语句时遇到错误，运行时错误 5（无效的过程调用或参数）。

答案1

我能够找到一个解决方案/编写一个更好的脚本。

  • 根据我的目的需求选择尺寸
  • 进行选择并尝试查找 A 列中具有重复值的行。（在我的例子中，这些是车辆 ID）
  • 如果找到匹配项，它将 B、C、D 的值与下面匹配 ID 行的 B、C、D 值相加
  • 删除重复行（当前行下方的行）
  • 如果有最多 4 个重复项，则遍历此循环 3 次（我的数据允许这样做；我尝试了动态解决方案但失败了。有什么提示吗？）
  • 调整选择的大小以删除多余的零值行

欢迎任何反馈，尤其是如何使未知数量的重复项动态化。

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

相关内容