0

VBAを使用してExcelで重複するセル値をマージしようとしています。データの例を次に示します。

Col1 Col2
run 1
run 2
see 9
go 5
see 1

データが次のようになるように、この情報をマージする必要があります。

Col1 Col2
run 3
see 10
go 5

つまり、列1の重複する値をマージし、列2の対応する値を合計する必要があります。

私はすでにここで同様の状況を調べて試しました：VBAを使用してExcelで同様の行を合計/マージする方法は？

推奨事項の1つは、次のマクロでした。

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がクラッシュする無限ループを作成しているようです。

必要なマージソリューションに到達するためにこのコードをどのように適応させることができるかについて誰かが何か提案がありますか？

4

2 に答える 2

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
于 2013-03-07T12:56:45.943 に答える
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
于 2013-03-07T12:45:50.587 に答える