ExcelVBAで一定ルールでの行追加

質問

いつもお世話になっています。

ExcelVBAについて教えて下さい。

以下のような表があったとします。

--|--A--|--B----|--C--|--D--|--E--|
-||-性別-|-年代-|-数1-|-数2-|-数3-|
1|---1--|--40--|---5--|--0--|--3--|
2|---1--|--55--|---0--|--1--|--0--|
3|---1--|--60--|---2--|--1--|--0--|
4|---1--|--70--|---3--|--0--|--2--|
5|---1--|--90--|---0--|--1--|--1--|
6|---1--|-100--|---1--|--1--|--0--|
7|---2--|--45--|---4--|--2--|--1--|
8|---2--|--50--|---0--|--3--|--5--|

性別はコード別で、年代は40から100までが5才刻みですが、数(集計された結果)が無い年代は行がありません。

表は元々与えられた物なのですが別に使用するので、数が無くてもすべての年代が入っている表に作り替えたいと思っています。縦横の合計値も同時に出すのと、こういった表を100近く処理しないといけないので、表ごとに抜けている年代を確認して挿入…というのは手間がかかり、また複数のファイルを処理するのでVBAでやった方がよいと思いましたが、自分で書いてみてもうまくいきませんでした。

実現させたい形は以下の通りです。
・男性
　40/45/50/55/60/65/70/75/80/85/90/95/100
　・男性の40から100までの年代ができたら、
　100の下に男性の数(縦)の合計値
　・男性の合計の下に、男性と同様に女性
　・女性の100の下に女性の合計値
　・数3の横列に1列追加して、年代別合計と男性と女性の総数

以上なのですが、お助けいただけますと幸いです。

よろしくお願い致します。

回答No.1

watabe007 · ベストアンサー

１行目は項目名(性別、年代、数、数2、数3)
データは２行目からとしています。
参考に
Sub Test()
　　Dim myDic As Object
　　Dim LastRow As Long
　　Dim Str As Variant
　　Dim i As Long, j As Long

　　Set myDic = CreateObject("Scripting.Dictionary")
　　LastRow = Cells(Rows.Count, "A").End(xlUp).Row
　　For i = 2 To LastRow
　　　　Str = Cells(i, "A").Value & ";" & Cells(i, "B").Value
　　　　myDic(Str) = Empty
　　Next
　　For i = 1 To 2
　　　　For j = 40 To 100 Step 5
　　　　　　Str = i & ";" & j
　　　　　　If Not myDic.Exists(Str) Then
　　　　　　　　LastRow = LastRow + 1
　　　　　　　　Cells(LastRow, "A").Value = i
　　　　　　　　Cells(LastRow, "B").Value = j
　　　　　　　　Cells(LastRow, "C").Resize(, 3).Value = 0
　　　　　　End If
　　　　Next
　　Next
　　Range("F2:F" & LastRow + 2).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
　　With Cells(LastRow + 1, "A")
　　　　.Value = 1
　　　　.Offset(, 1).Value = "男性計"
　　　　.Offset(, 2).Resize(, 4).FormulaR1C1 = "=SUM(R[-13]C:R[-1]C)"
　　End With
　　With Cells(LastRow + 2, "A")
　　　　.Value = 2
　　　　.Offset(, 1).Value = "女性計"
　　　　.Offset(, 2).Resize(, 4).FormulaR1C1 = "=SUM(R[-13]C:R[-1]C)"
　　End With
　　Range("A2:F" & LastRow + 2).Sort _
　　Key1:=Range("A2"), Order1:=xlAscending, _
　　Key2:=Range("B2"), Order2:=xlAscending, _
　　Header:=xlNo
　　Set myDic = Nothing
End Sub

お礼

遅くなりまして申し訳ありませんでした。ありがとうございました。