Excel VBAで条件に合わせて行をまとめる

質問

Excel VBAは初心者なので皆様のお知恵を拝借したいです。

No列、名称列、年月列、金額A列、金額B列があるExcelファイルを
以下のような条件のときに行をまとめたいです。
【まとめる条件】
・Noが同じである
・年月が同じである
・名称に★マークが含まれていない

列をまとめた際の名称は一番上の名称をしようします。
また金額A・Bはそれぞれ合算したいです。

お知恵のある方はどうかお力をお貸しください。
よろしくお願い致します。

回答No.4

kkkkkm

No3一部抜けがありましたので訂正です

Sub Test()
Dim LastRow As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet

Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")

Sh1.Range("A1").AutoFilter
Sh1.Activate
Sh1.Range(Cells(1, "A"), Sh1.Cells(Rows.Count, "E").End(xlUp)).AutoFilter Field:=2, Criteria1:="<>*★*", _
Operator:=xlAnd
Sh1.Range(Cells(1, "A"), Sh1.Cells(Rows.Count, "E").End(xlUp)).Copy
Sh2.Range("A1").PasteSpecial
Application.CutCopyMode = False
Sh2.Activate
Sh2.Range(Cells(1, "A"), Sh2.Cells(Rows.Count, "E").End(xlUp)).RemoveDuplicates Columns:=Array(1, 3), Header _
:=xlYes
Sh2.Range("D2").Select
Sh2.Range("D2").Formula = _
"=SUMIFS(Sheet1!D:D,Sheet1!$A:$A,Sheet2!$A2,Sheet1!$C:$C,Sheet2!$C2,Sheet1!$B:$B,""<>*★*"")"
Sh2.Range("D2").AutoFill Destination:=Sh2.Range("D2:E2"), Type:=xlFillDefault
LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row
Sh2.Range("D2:E2").AutoFill Destination:=Sh2.Range(Sh2.Cells(2, "D"), Sh2.Cells(LastRow, "E")), Type:=xlFillDefault
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.3

kkkkkm

エクセルのマクロの記録でほとんどのコードが取得できます。ただし単純なデータで確かめただけなので結果が絶対正しいとは言えません。

もとのデータがSheet1の
No列がA列、名称列がB列、年月列がC列、金額A列がD列、金額B列がE列
1行目が項目2行目からデータ
でSheet2にまとめたデータをA1から記載する場合として

マクロの記録を始めます
1)Sheet1のA1を選択して並び替えとフィルターでフィルターをオンにします。
2)名称列(B列)のフィルターでテキストフィルターで指定の値を含まないを選択して★を指定します。
3)フィルターされたデータの全ての範囲をコピーしてSheet2のA1に貼り付けます。バージョンによっては見えないセルもコピーされるかもしれません。その場合Alt+;を押してからコピーしてください。
4)Sheet2の貼り付けたデータをすべて選択してデータタブの「重複の削除」でNo列と年月列を選択して実行します。
5)金額A列のD2を選択して以下の数式を入れます。
=SUMIFS(Sheet1!D:D,Sheet1!$A:$A,Sheet2!$A2,Sheet1!$C:$C,Sheet2!$C2,Sheet1!$B:$B,"<>*★*")
6)D2をE2までフィルします。D2とE2をデータの最後の行までフィルします。
マクロの記録終了

以下はA1からE21までデータがある場合のマクロの記録でできたコードです。

Sub Macro1()
Range("A1").Select
Selection.AutoFilter
Range("A1:E21").Select
ActiveSheet.Range("$A$1:$E$21").AutoFilter Field:=2, Criteria1:="<>*★*", _
Operator:=xlAnd
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$E$18").RemoveDuplicates Columns:=Array(1, 3), Header _
:=xlYes
Range("D2").Select
ActiveCell.FormulaR1C1 = _
"=SUMIFS(Sheet1!C[-2],Sheet1!C1,Sheet2!RC1,Sheet1!C3,Sheet2!RC3,Sheet1!C2,""<>*★*"")"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:E2"), Type:=xlFillDefault
Range("D2:E2").Select
Selection.AutoFill Destination:=Range("D2:E6"), Type:=xlFillDefault
End Sub

以下は上記をもとに冗長な部分を整理して、行数が増えても対応できるように変更したものです。

Sub Test()
Dim LastRow As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet

Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")

Sh1.Range("A1").AutoFilter
Sh1.Activate
Sh1.Range(Cells(1, "A"), Cells(Rows.Count, "E").End(xlUp)).AutoFilter Field:=2, Criteria1:="<>*★*", _
Operator:=xlAnd
Sh1.Range(Cells(1, "A"), Cells(Rows.Count, "E").End(xlUp)).Copy
Sh2.Range("A1").PasteSpecial
Application.CutCopyMode = False
Sh2.Activate
Sh2.Range(Cells(1, "A"), Cells(Rows.Count, "E").End(xlUp)).RemoveDuplicates Columns:=Array(1, 3), Header _
:=xlYes
Sh2.Range("D2").Select
Sh2.Range("D2").Formula = _
"=SUMIFS(Sheet1!D:D,Sheet1!$A:$A,Sheet2!$A2,Sheet1!$C:$C,Sheet2!$C2,Sheet1!$B:$B,""<>*★*"")"
Sh2.Range("D2").AutoFill Destination:=Range("D2:E2"), Type:=xlFillDefault
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Sh2.Range("D2:E2").AutoFill Destination:=Range(Cells(2, "D"), Cells(LastRow, "E")), Type:=xlFillDefault
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.2

HohoPapa

シートのレイアウトがわからないので
・タイトル行が1行目にある。
・No.列は途中の行に空欄がない（上方向に詰まっている）
という条件にしてみました。

また、まとめる条件は以下ですね？
・Noが同じである　かつ、
・年月が同じである　かつ、
・名称に★マークが含まれていない

添付画像の内容なら
以下のコードで期待の動作になるものと思います。

Sub Sample()

　'変数定義
　Dim wsGet As Worksheet
　Dim wsPut As Worksheet
　Dim i As Long
　Dim j As Long
　Dim RecCnt As Long

　'定数定義（それぞれ列番号）
　Const ColN = 1　'No.列
　Const ColM = 2　'名称列
　Const ColD = 3　'年月列
　Const ColK1 = 4 '金額１列
　Const ColK2 = 6 '金額２列
　Const wkColNum1 = 8　　'作業列1
　Const wkColNum2 = 9　　'作業列2

　'ワークシート定義
　With ThisWorkbook
　　Set wsGet = .Sheets("Sheet1")　　'集計元シート
　　Set wsPut = .Sheets("Sheet2")　　'集計先シート
　End With

　'作業領域クリアー
　wsGet.Columns(wkColNum1).ClearContents
　wsGet.Columns(wkColNum2).ClearContents

　'作業列編集
　i = 2
　Do
　　If wsGet.Cells(i, ColN).Value = "" Then Exit Do
　　If InStr(wsGet.Cells(i, ColM).Value, "★") = 0 Then
　　　wsGet.Cells(i, wkColNum1).Value = _
　　　　wsGet.Cells(i, ColN).Value & _
　　　　wsGet.Cells(i, ColD).Value
　　Else
　　　wsGet.Cells(i, wkColNum1).Value = _
　　　　i & "_" & _
　　　　wsGet.Cells(i, ColN).Value & _
　　　　wsGet.Cells(i, ColM).Value & _
　　　　wsGet.Cells(i, ColD).Value
　　End If
　　i = i + 1
　Loop
　wsGet.Columns(wkColNum1).Copy wsGet.Columns(wkColNum2)
　wsGet.Columns(wkColNum2).RemoveDuplicates Columns:=1, Header:=xlNo

　'統合転記先クリアー、タイトル行出力
　wsPut.Cells.ClearContents
　wsGet.Rows(1).Copy wsPut.Rows(1)

　'作業列をもとに統合転記
　RecCnt = i - 2　　'データの総レコード数取得
　i = 2
　'MsgBox RecCnt
　Do
　　If wsGet.Cells(i, wkColNum2).Value = "" Then Exit Do
　　For j = RecCnt + 1 To 2 Step -1
　　　If wsGet.Cells(j, wkColNum1).Value = _
　　　　wsGet.Cells(i, wkColNum2).Value Then
　　　　wsPut.Cells(i, ColN).Value = wsGet.Cells(j, ColN).Value
　　　　wsPut.Cells(i, ColM).Value = wsGet.Cells(j, ColM).Value
　　　　wsPut.Cells(i, ColD).Value = wsGet.Cells(j, ColD).Value
　　　　wsPut.Cells(i, ColK1).Value = _
　　　　　wsPut.Cells(i, ColK1).Value + wsGet.Cells(j, ColK1).Value
　　　　wsPut.Cells(i, ColK2).Value = _
　　　　　wsPut.Cells(i, ColK2).Value + wsGet.Cells(j, ColK2).Value
　　　End If
　　Next j
　　i = i + 1
　Loop

　'作業列クリアー
'　wsGet.Columns(wkColNum1).ClearContents
'　wsGet.Columns(wkColNum2).ClearContents

End Sub

回答No.1

imogasi

＞VBAは初心者なので
文法を齧っても、下記のような「処理ロジック」の訓練をしなければ、駄目で、
いろんなケースに出くわして、真似るほかない。
ーー
以下はソート法とでもいうべき処理ロジック。
（１）A列（NO)でソートしてみて
そのNO順に並んでいる各Noの切れ目で、直前のNoの金額A列、金額B列の
出せばよいのでは。
（２）年月については、ソートの結果が、年月順になるかどうかやってみればよい。もし乱れるようなら、年数字４桁＋月数字２桁のデータを新しい列に作って、その列でソートして（１）と同じ考え方法を適用する。
（３）名称に★マークが含まれていない
は、p=Instr（セルの値、”★")で判別すればよい。
ーー
A,B冽データ　A1:B6
名前 計数
AA★A 2
BBB 3
ＣＣ★ 4
ＤＤＤ 5
★SSD 6
標準moduleに
Sub test01()
s = 0
For i = 2 To 6
p = InStr(Cells(i, "A"), "??")
If p <> 0 Then s = s + Cells(i, "B")
Next i
MsgBox s
End Sub
結果
６が表示される。
ーーー
例データ　A1:B8
NO 計数
1 1
1 2
2 3
2 4
2 5
3 6
3 7
標準モジュール
Sub test02()
Dim mae
k = 2
'---最初のデータ行
mae = Cells(2, "A")
s = s + Cells(2, "B")
'---第３行以下
For i = 3 To 8
If Cells(i, "A") = mae Then
s = s + Cells(i, "B")
Else
'変わった
Cells(k, "F") = mae
Cells(k, "G") = s
k = k + 1
s = 0 'ご破算
mae = Cells(i, "A")
s = s + Cells(i, "B")
End If
Next i
'--
Cells(k, "F") = mae
Cells(k, "G") = s
End Sub
ーー
実行後F2:G4
1 3
2 12
3 13
＝＝＝
関数SUMIF法
No列や名称列の、重複のないデータを１列に作れるなら（フィルタオプションで作れる）
そのデータをSUMIF関数の条件にして、計数列の係数の合計などが出せる。
=SUMIF(A2:A8,F2,B2:B8)下へ式を複写。
F列　　G列　I列＝式を入れた列。
1 3 3
2 12 12
3 13 13
関数から学び始めた人はこれがよいかも。
I1 3 3
2 12 12
3 13 13
1 3 3
2 12 12
3 13 13
VBAなら
Sub test03()
For i = 2 To 4
Cells(i, "I") = Application.WorksheetFunction.SumIf(Range("a2:A8"), Cells(i, "F"), Range("B2:B8"))
Next i
End Sub
＝＝＝
「年月が同じである」分は、模擬データを挙げてくれればやってみる。
年月データの扱いは、エクセルでは要注意ですから、軽々しく回答できない。