使用VBA在Excel中合并重复的单元格值及其总和

时间:2013-03-07 12:10:01

标签: vba excel-vba merge duplicates excel

我正在尝试使用VBA合并Excel中的重复单元格值。 以下是数据示例:

  

Col1 Col2
  跑1   跑2   见9
  去5
  见1

我需要合并这些信息,以便数据如下:

  

Col1 Col2
  跑3   见10
  去5

意思是,我需要合并第1列中的重复值,并在第2列中对它们的相应值求和。

我已经咨询并尝试了类似的情况:How to SUM / merge similar rows in Excel using VBA?

其中一个建议是以下宏:

Sub Macro1()
Dim ColumnsCount As Integer

ColumnsCount = ActiveSheet.UsedRange.Columns.Count

ActiveSheet.UsedRange.Activate


Do While ActiveCell.Row <= ActiveSheet.UsedRange.Rows.Count
    If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then
        For i = 1 To ColumnsCount - 1
            ActiveCell.Offset(0, i).Value = ActiveCell.Offset(0, i).Value + ActiveCell.Offset(1, i).Value
        Next
        ActiveCell.Offset(1, 0).EntireRow.Delete shift:=xlShiftUp
    Else
        ActiveCell.Offset(1, 0).Select
    End If
Loop
End Sub

然而,它似乎正在创建一个无限循环,导致我的excel崩溃,而不实际合并任何东西。

有没有人对如何调整此代码以获得我需要的合并解决方案有任何建议?

2 个答案:

答案 0 :(得分:3)

以下假设您的表在单元格A1中开始,而C列以后是空的(如果它们不是,您将丢失合并行上的数据)

Sub mergeCategoryValues()
Dim lngRow As Long

With ActiveSheet

    lngRow = .Cells(.LastCell.Row, 1).End(xlUp).Row

    .Cells(1).CurrentRegion.Sort key1:=.Cells(1), header:=xlNo 'change this to xlYes if your table has header cells

    Do

        If .Cells(lngRow - 1, 1) = .Cells(lngRow, 1) Then
            .Cells(lngRow - 1, 2) = .Cells(lngRow - 1, 2) + .Cells(lngRow, 2)
            .Rows(lngRow).Delete
        End If

        lngRow = lngRow - 1

    Loop Until lngRow < 2

End With

End Sub

答案 1 :(得分:2)

尝试这个(首先排序,然后运行你的代码):

Sub Merge()

Dim ColumnsCount As Integer
Dim i As Integer

Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

Do While ActiveCell.Row <= ActiveSheet.UsedRange.Rows.Count
    If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then
        For i = 1 To ColumnsCount - 1
            ActiveCell.Offset(0, i).Value = ActiveCell.Offset(0, i).Value +     ActiveCell.Offset(1, i).Value
        Next
        ActiveCell.Offset(1, 0).EntireRow.Delete shift:=xlShiftUp
    Else
        ActiveCell.Offset(1, 0).Select
    End If
Loop

End Sub