VBA 一致項目の 合計

Question

＿　　　A　　　　B　　　　C　　　　D　　　　E
１　　100A　　　あ　　　　い　　　300　　　500
２　　100A　　　う　　　　え　　　500　　　200
３　　100B　　　お　　　　か　　　　0　　　50
４　　100B　　　き　　　　く　　　100　　　100
５　　200　　 　け　　　　こ　　　100　　　100
６　　300　　　 さ　　　　し　　　100　　　100
７　　400　　 　す　　　　せ　　　100　　　100

のような値があるときに、Aが同じ数字だった際に上の行だけ残し、D,Eは数を合計したいです。

その際のコードを教えていただきたいです。
行数としては2000行程度ありその中から同じ数字を抽出、合算をしたいため関数よりマクロで処理したいと考えています。
データの更新とともに貼り付けをするため関数だと都度組まないといけない為。。。

Comments

[1T2R3M4]

コードをください・デバッグしてください等の丸投げの質問
何かを作りたいのでコードを書いてほしい、学校の課題を解いてほしい等の質問は、具体的にプログラミングで困っている質問ではないと考え、推奨していません。

当然既読だとは思いますが、以下再度確認してください。
https://teratail.com/help/avoid-asking

[meg_]

> Aが同じ数字だった際に上の行だけ残し
｢数字｣に着目するということはアルファベットは無視するというとこですね？また、データは常にソート済みですね？

Answer 1

Sub Main()

Dim oShIn As Object
Set oShIn = ThisWorkbook.Sheets("もとデータ")
Dim oShOut As Object
Set oShOut = ThisWorkbook.Sheets("合算")

Dim iRow As Long
iRow = oShIn.UsedRange.Rows.Count
oShIn.Range("A1:A" & iRow).Copy
oShOut.Range("A1").PasteSpecial Paste:=xlPasteValues

oShOut.Range("A:A").RemoveDuplicates Columns:=Array(1)

oShOut.Range("D1").Formula = "=SUMIF(もとデータ!$A$1:$A$" & iRow _
    & ",合算!$A1,もとデータ!$D$1:$D$" & iRow & ")"
oShOut.Range("E1").Formula = "=SUMIF(もとデータ!$A$1:$A$" & iRow _
    & ",合算!$A1,もとデータ!$E$1:$E$" & iRow & ")"

iRow = oShOut.UsedRange.Rows.Count
oShOut.Range("D1:E1").Copy
oShOut.Range("D2:E" & iRow).PasteSpecial Paste:=xlPasteFormulas

Application.CutCopyMode = False

End Sub

もとのシート名を「もとデータ」、合算の出力シート名を「合算」とします。
例示いただいたとおり、データの開始行は１行目とします。
「合算」シートへの合算の出力先は、もとデータと同じくD列、E列とします。
行や列に関する数字・アルファベットは実際に応じて変えていただければ
良いと思います。

処理内容は、A列をコピーして重複行を削除して、SUMIFの式を入れて、
その式を行数分コピーするというものです。
手でもできます。それをマクロでやるというものです。

Answer 2

もしかすると、メニューから「おすすめピボットテーブル」あたりの機能でポチポチやった方が
早く目的のものが得られるのかもしれませんが、マクロで作るなら例えばこんな感じでしょうか。

Sub sample1()
    
    Dim ws1 As Worksheet
    Set ws1 = Worksheets(1)
    
    Dim ws2 As Worksheet
    Set ws2 = Worksheets.Add(, ws1)
    
    Dim i, j, k
    For i = 1 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
        If WorksheetFunction.CountIf(ws2.Columns(1), ws1.Cells(i, 1)) = 0 Then
            j = j + 1
            ws1.Rows(i).Resize(, 5).Copy ws2.Cells(j, 1)
        Else
            k = WorksheetFunction.Match(ws1.Cells(i, 1), ws2.Columns(1), False)
            ws2.Cells(k, 4) = ws2.Cells(k, 4) + ws1.Cells(i, 4)
            ws2.Cells(k, 5) = ws2.Cells(k, 5) + ws1.Cells(i, 5)
        End If
    Next
    
End Sub

Sub sample2()
    Dim rng As Range, ws As Worksheet
    Set rng = Worksheets(1).UsedRange
    Set ws = Worksheets.Add(, rng.Worksheet)
    ws.Range(rng.Address).Value = rng.Value
    ws.UsedRange.RemoveDuplicates 1
    ws.UsedRange.Columns(4).Resize(, 2).Formula = "=SUMIF(" & rng.Columns(1).Address(True, True, , True) & "," & ws.Cells(1, 1).Address(False, True, , True) & "," & rng.Columns(4).Address(True, False, , True) & ")"
    ws.UsedRange.Value = ws.UsedRange.Value
End Sub

---

もしかして、100Aと100Bは同じ100として合算するのですか。

Sub sample3()
    
    Dim ws1 As Worksheet
    Set ws1 = Worksheets(1)
    
    Dim ws2 As Worksheet
    Set ws2 = Worksheets.Add(, ws1)
    
    Dim i, j, k, v
    For i = 1 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
        v = Val(ws1.Cells(i, 1).Value)
        If WorksheetFunction.CountIf(ws2.Columns(1), v) = 0 Then
            j = j + 1
            ws1.Rows(i).Resize(, 5).Copy ws2.Cells(j, 1)
            ws2.Cells(j, 1).Value = v
        Else
            k = WorksheetFunction.Match(v, ws2.Columns(1), False)
            ws2.Cells(k, 4) = ws2.Cells(k, 4) + ws1.Cells(i, 4)
            ws2.Cells(k, 5) = ws2.Cells(k, 5) + ws1.Cells(i, 5)
        End If
    Next
    
End Sub