EXCELでマクロを使用して表を作成するには？

質問

EXCEL2000にて、“マクロ”を使って必要事項を入力すれば、下記のような流れで自動的に表を作成することは可能でしょうか？

１．必要事項を入力。

　　　　A列　　　　B列　　　　　 C列
A行　（工事名）　（名前）　 （作業時間）
B行　　下水　　　　タナカ　　 　10.0
C行　　下水　　　　ヤマダ　　　　8.0
D行　　上水 　 　　スズキ　　　　5.5
E行　　道路　　　　スズキ　　　　2.0
F行　　道路　　　　タナカ　　　　4.5
G行　　上水　　　　カトウ　　　 15.0

２．別のシートに１で入力した内容を集計

　　　　A列　 B列　 　C列　 　　D列　 　E列
A行　　　　　 タナカ　 ヤマダ　 スズキ　 カトウ　
B行　　下水　　10.0 　 8.0 　 　　0.0 　　 0.0
C行　　上水 　 0.0 　　 0.0 　　 　5.5 　 15.0
D行　　道路 　 4.5　　　 0.0 　　 2.0 　　 0.0

私自身は関数（SUMPRODUCT）かピボットテーブルでなら、どうにか作成できるのですがマクロに関しては初心者で、ほとんどわかりません。

現在、入門書を購入して最初の項目を勉強中ですが、業務上、急いで作成しないといけないため、どなたかお教えいただけないでしょうか？

どうぞよろしくお願いいたします。

回答No.5

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

ピボットテーブルを使用する方法でマクロを書いてみました。Sheet2 をアクティブにすると自動的に作表する仕組みになっています。

【手順】
1.　シート選択タブ上で右クリック「コードの表示」
2.　以下のコードをコピー＆ペースト
3.　Visual Basic Editor を閉じる

Private Sub Worksheet_Activate()

　　Dim rngDat As Range
　　Dim pvtTbl As PivotTable

　　'データ範囲※
　　Set rngDat = ThisWorkbook.Sheets("Sheet1") _
　　　　.Range("A1").CurrentRegion

　　'ピボットテーブル作成
　　Application.ScreenUpdating = False
　　Me.Cells.Clear
　　Set pvtTbl = ThisWorkbook.PivotCaches.Add(xlDatabase, rngDat) _
　　　　.CreatePivotTable( _
　　　　TableDestination:=Me.Range("A1"), _
　　　　TableName:="_Result")
　　With pvtTbl
　　　　.AddFields RowFields:=rngDat.Cells(1, 2).Value, _
　　　　　　　　ColumnFields:=rngDat.Cells(1, 1).Value
　　　　With .PivotFields(rngDat.Cells(1, 3).Value)
　　　　　　.Orientation = xlDataField
　　　　　　.NumberFormat = "#,##0.0_ "
　　　　End With
　　　　.RowGrand = True　　'行計
　　　　.ColumnGrand = True '列計
　　　　.NullString = "0"
　　　　.MergeLabels = True
　　End With

　　Set pvtTbl = Nothing
　　Set rngDat = Nothing

End Sub

お礼

こういうマクロもあるんですね！
できあがった表の完成度に、つい感心してしまいました。

マクロの内容に対して、理解するのにもう少し時間がかかりますが、いい勉強になりました。

ありがとうございました。

回答No.4

Wendy02

#3 のWendy02 です。

SUMPRODUCT という言葉で、加算されることだと分り、自分のコードの間違いに気がつきました。#3のコードは、ボツです。

この行の部分が修正されました。
Sh2.Cells(rnum, cnum).Value = Cells(i, 3).Value
　　↓
Sh2.Cells(rnum, cnum).Value = Sh2.Cells(rnum, cnum).Value + Cells(i, 3).Value

後は、Sh2 のデータ部分がクリアされます。

'===========================================
Sub testSample2()
　 Dim rnum As Long, cnum As Long, ct As Long, i As Long
　 Dim Sh2 As Worksheet
　 '----------------------------------
　 '設定
　 Set Sh2 = Worksheets("Sheet2")
　 '----------------------------------

　 '項目を入れる（不要の場合は、ここを抜く)
　 Sh2.Range("A2:A4").Value = WorksheetFunction.Transpose(Array("下水", "上水", "道路"))
　 Sh2.Range("A1").CurrentRegion.Offset(1, 1).ClearContents
　 Worksheets("Sheet1").Select
　 Application.ScreenUpdating = False
　 For i = 2 To Range("A65536").End(xlUp).Row
　　　On Error Resume Next
　　　'人名を探す
　　　cnum = WorksheetFunction.Match(Cells(i, 2).Value, Sh2.Rows(1), 0)
　　　On Error GoTo 0
　　　'ない場合
　　　If cnum = 0 Then
　　　　 ct = Sh2.Cells(1, 256).End(xlToLeft).Column + 1
　　　　 Sh2.Cells(1, ct).Value = Cells(i, 2).Value
　　　　 cnum = ct
　　　　 Err.Clear
　　　End If
　　　rnum = WorksheetFunction.Match(Cells(i, 1).Value, Sh2.Range("A2:A4"), 0) + 1
　　　Sh2.Cells(rnum, cnum).Value = Sh2.Cells(rnum, cnum).Value + Cells(i, 3).Value
　　　cnum = 0: rnum = 0
　 Next i

　 With Sh2.Range("A1").CurrentRegion
　　　.NumberFormatLocal = "0.0"
　　　On Error Resume Next
　　　'空いているところに、0を入れる
　　　.SpecialCells(xlCellTypeBlanks).Value = 0
　　　On Error GoTo 0
　　　.Cells(1, 1).ClearContents
　 End With
　 Application.ScreenUpdating = True
End Sub

お礼

再度書き込みいただき、恐縮です。
訂正内容でバッチリです！
No.3での書き込みを含めて、参考になりました。
ありがとうございました。

回答No.3

Wendy02

こんばんは。

あまり入門書を読んでいる最中には、あれこれ手を出すと、自分が何をやっているか分らなくなります。だから、参考にするのもよいし、そうでなくてもよいと思います。
今回は、ワークシート関数のMatch を使いましたが、こういう検索に関する関数は、なかなか慣れないと失敗しやすいです。以下は、なるべく、初級の書き方にしましたが、さて、どうでしょうか？

'<標準モジュール>
Sub testSample()
　 Dim rnum As Long, cnum As Long, ct As Long, i As Long
　 Dim Sh2 As Worksheet
　 '----------------------------------
　 '設定
　 Set Sh2 = Worksheets("Sheet2")
　 '----------------------------------
　 '項目を入れる（不要の場合は、ここを抜く)
　 Sh2.Range("A2:A4").Value = WorksheetFunction.Transpose(Array("下水", "上水", "道路"))
　Worksheets("Sheet1").Select
　 Application.ScreenUpdating = False
　 For i = 2 To Range("A65536").End(xlUp).Row
　　　On Error Resume Next
　　　'人名を探す
　　　cnum = WorksheetFunction.Match(Cells(i, 2).Value, Sh2.Rows(1), 0)
　　　On Error GoTo 0
　　　'ない場合
　　　If cnum = 0 Then
　　　　 ct = Sh2.Cells(1, 256).End(xlToLeft).Column + 1
　　　　 Sh2.Cells(1, ct).Value = Cells(i, 2).Value
　　　　 cnum = ct
　　　　 Err.Clear
　　　End If
　　　rnum = WorksheetFunction.Match(Cells(i, 1).Value, Sh2.Range("A2:A4"), 0) + 1
　　　Sh2.Cells(rnum, cnum).Value = Cells(i, 3).Value
　　　cnum = 0: rnum = 0
　 Next i
　 With Sh2.Range("A1").CurrentRegion
　　　.NumberFormatLocal = "0.0"
　　　On Error Resume Next
　　　'空いているところに、0を入れる
　　　.SpecialCells(xlCellTypeBlanks).Value = 0　
　　　On Error GoTo 0
　　　'Sh2のA1の0を消す
　　　.Cells(1,1).ClearContents
　 End With
　 Application.ScreenUpdating = True
End Sub

お礼

文頭での御言葉に、感涙(T_T)・・・と書くと大げさかもしれませんが、実際に頭の中がゴチャゴチャしていただけに、余計に心に染みました。
ありがとうございました。

回答No.2

imogasi

Sheet1に
元シートの保存が必要なら別シートにコピーするか、コピーしたシートを造ってください。
（工事名） （名前） （作業時間）
下水 タナカ 10
下水 ヤマダ 8
上水 スズキ 5.5
道路 スズキ 2
道路 タナカ 4.5
上水 カトウ 15
とあるとします。
ソートはＶＢＡでもできますが、今回は手作業でします。
工事名の列でソートします。
（工事名） （名前） （作業時間）
下水 タナカ 10
下水 ヤマダ 8
上水 スズキ 5.5
上水 カトウ 15
道路 スズキ 2
道路 タナカ 4.5
上水が上だとかあれば、ワーク列にＶＬＯＯＫＵＰでコード１，２，３を
振って、その列でソートしてください。
ＶＢＡは標準モジュールにコピー。
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
'----
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
'-----Ｓｈｅｅｔ１の最下行を求める
d1 = sh1.Range("A65536").End(xlUp).Row
MsgBox d1
'----初期設定
k = 2 'Sheet2の書き込む行
m = 2 'Sheet2の名前の現在の最右列
'-----
For i = 2 To d1
If sh1.Cells(i, "A") <> mk Then '工事名につき前行と変わったか
k = k + 1
sh2.Cells(k, "A") = sh1.Cells(i, "A") 'Sheet2Ａ列にSheet1から工事名セット
End If
'----名前が等しい列探し
For j = 2 To m
If sh2.Cells(2, j) = sh1.Cells(i, "B") Then '名前が等しいか
sh2.Cells(k, j) = sh1.Cells(i, "C") '名前が等しい列に時間セット
GoTo p01
End If
Next j
'----名前見つからず
m = m + 1
sh2.Cells(2, m) = sh1.Cells(i, "B")
sh2.Cells(k, m) = sh1.Cells(i, "C")
p01:
mk = sh1.Cells(i, "A")
Next i
End Sub
結果
Ｓｈｅｅｔ２に

タナカ ヤマダ スズキ カトウ
下水 10 8
上水 5.5 15
道路 4.5 2

お礼

ＶＢＡの内容に入る前の手順を付け加えていただいたり、ＶＢＡ内のコメントの記載もあり、頭に入りやすかったです。

ありがとうございました。

回答No.1

masa_019

こんばんは。
関数でも十分可能だと思います。

必要事項を記入するシートをSheet1、別シートを
Sheet2とします。

Sheet2のセルB2に
=SUMPRODUCT((Sheet1!$B$2:$B$7=$A2)*(Sheet1!$C$2:$C$7=B$1)*Sheet1!$D$2:$D$7)
と入力して縦横にオートフィルでコピーしてみて下さい。

Sheet1を集計した表が出来ると思います。

お礼

＞関数でも十分可能だと思います。

私もそのように思いましたが、
上司から「マクロで作成してほしい」という指示がありましたので・・・。
（「面倒かも知れないけど、関数よりもマクロの方がいい！」という感じです。）

とはいえ、
SUMPRODUCTに関しても、理解度が低かったので、参考になりました。

ありがとうございました。