在合并循环中删除了错误的行



>情况:我有数据,我试图通过根据第一列值(项目 ID 号)对行求和来合并。如果 ID 号匹配,我希望将行相加并删除重复的行。

我编写了以下代码,遇到了 2 个问题:1. 第一次运行代码时,总会留下一些未合并的重复项 2.如果我再次运行代码,它会对行求和并删除行,即使它们不是重复的。

任何帮助将不胜感激。

Sub ConsolidateRows()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim iRow As Long
    Dim iCol As Long
    Dim LastRow As Long
    Dim LastCol As Long
    Dim duplicate As String
    Dim dupRow As Long
    Dim cell As Range
    Dim i As Integer
   'set
    Set WB = Workbooks("Book1")
    Set WS = WB.Sheets("Data")
    LastRow = WS.UsedRange.Rows.Count
    LastCol = WS.UsedRange.Columns.Count
    'Loop to consolidate, delete the duplicate rows
    iRow = 1
    While WS.Cells(iRow, 1).Value <> ""
        duplicate = Cells(iRow, 1).Value
        iRow = iRow + 1
        For Each cell In WS.Range("A1:A" & LastRow).Cells
                dupRow = cell.Row
            If cell.Value = duplicate And iRow <> dupRow Then
                For iCol = 3 To LastCol
                        Cells(iRow, iCol) = Application.WorksheetFunction.Sum(Cells(iRow, iCol), Cells(dupRow, iCol))
                Next iCol
                WS.Rows(dupRow).Delete
            End If
        Next cell
    Wend
End Sub

删除行时,始终从底部开始,然后逐步向上。

例如,如果第 1-5 行的列 A 包含:

Alpha
Bravo
Charlie
Delta
Foxtrot

并删除第 3 行,您现在有

Alpha
Bravo
Delta
Foxtrot

你的循环计数器(值 3)在删除之前指向Charlie但现在指向Delta,然后你把计数器递增到4,它指向Foxtrot,因此你从未评估是否需要删除Delta

试试这个:

'Loop to consolidate, delete the duplicate rows
iRow = LastRow
While WS.Cells(iRow, 1).Value <> ""
    duplicate = Cells(iRow, 1).Value
    iRow = iRow - 1
    For Each cell In WS.Range("A1:A" & LastRow -1).Cells
            dupRow = cell.Row
        If cell.Value = duplicate And iRow <> dupRow Then
            For iCol = 3 To LastCol
                    Cells(iRow, iCol) = Application.WorksheetFunction.Sum(Cells(iRow, iCol), Cells(dupRow, iCol))
            Next iCol
            WS.Rows(dupRow).Delete
            LastRow = LastRow - 1
        End If
    Next cell
Wend

*注意:代码更改在我的头顶上,您可能需要进行一些小的额外调整才能使其向后运行

另外,请调查.Find() - 这将使您的代码运行速度显着加快以查找重复。

最新更新