![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
EXCEL2000にて、“マクロ”を使って必要事項を入力すれば、下記のような流れで自動的に表を作成することは可能でしょうか?
1.必要事項を入力。
A列 B列 C列
A行 (工事名) (名前) (作業時間)
B行 下水 タナカ 10.0
C行 下水 ヤマダ 8.0
D行 上水 スズキ 5.5
E行 道路 スズキ 2.0
F行 道路 タナカ 4.5
G行 上水 カトウ 15.0
2.別のシートに1で入力した内容を集計
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 です。ピボットテーブルを使用する方法でマクロを書いてみました。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
- 回答日時:
#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
- 回答日時:
こんばんは。
あまり入門書を読んでいる最中には、あれこれ手を出すと、自分が何をやっているか分らなくなります。だから、参考にするのもよいし、そうでなくてもよいと思います。
今回は、ワークシート関数の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
- 回答日時:
Sheet1に
元シートの保存が必要なら別シートにコピーするか、コピーしたシートを造ってください。
(工事名)(名前)(作業時間)
下水タナカ10
下水ヤマダ8
上水スズキ5.5
道路スズキ2
道路タナカ4.5
上水カトウ15
とあるとします。
ソートはVBAでもできますが、今回は手作業でします。
工事名の列でソートします。
(工事名)(名前)(作業時間)
下水タナカ10
下水ヤマダ8
上水スズキ5.5
上水カトウ15
道路スズキ2
道路タナカ4.5
上水が上だとかあれば、ワーク列にVLOOKUPでコード1,2,3を
振って、その列でソートしてください。
VBAは標準モジュールにコピー。
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
'----
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
'-----Sheet1の最下行を求める
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") 'Sheet2A列に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
結果
Sheet2に
タナカヤマダスズキカトウ
下水108
上水5.515
道路4.52
VBAの内容に入る前の手順を付け加えていただいたり、VBA内のコメントの記載もあり、頭に入りやすかったです。
ありがとうございました。
No.1
- 回答日時:
こんばんは。
関数でも十分可能だと思います。
必要事項を記入するシートを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に関しても、理解度が低かったので、参考になりました。
ありがとうございました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・ゆるやかでぃべーと タイムマシンを破壊すべきか。
- ・「I love you」 をかっこよく翻訳してみてください
- ・歩いた自慢大会
- ・許せない心理テスト
- ・字面がカッコいい英単語
- ・昔のあなたへのアドバイス
- ・かっこよく答えてください!!
- ・あなたが好きな本屋さんを教えてください
- ・スタッフと宿泊客が全員斜め上を行くホテルのレビュー
- ・【大喜利】【投稿~8/27】 こんなガソリンスタンド二度と来るか!なぜそう思った?
- ・これ何て呼びますか Part2
- ・人生で一番思い出に残ってる靴
- ・【お題】動物のキャッチフレーズ
- ・【お題】甲子園での思い出の残し方
- ・ゆるやかでぃべーと すべての高校生はアルバイトをするべきだ。
- ・「それ、メッセージ花火でわざわざ伝えること?」
- ・自分用のお土産
- ・人生で一番お金がなかったとき
- ・一番好きなみそ汁の具材は?
- ・泣きながら食べたご飯の思い出
- ・ちょっと先の未来クイズ第1問
- ・ゴリラ向け動画サイト「ウホウホ動画」にありがちなこと
- ・初めて自分の家と他人の家が違う、と意識した時
- ・単二電池
- ・チョコミントアイス
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【マクロ】ファイル名の一括変...
-
エクセルでの2項目比較および...
-
【マクロ】フォルダ内にあるPDF...
-
Excelの条件付き書式について
-
【マクロ】functionプロシージ...
-
Excelの警告について
-
エクセルの数式バーのフォント...
-
EXCELの散布図で日付が1900年に...
-
エクセルでファイルの最終更新...
-
エクセルまたはGoogleスプレッ...
-
Excelで数値を時間数に変換する...
-
エクセル IF計算式?でしょうか?
-
エクセルで数字の組み合わせを...
-
2列に入っているデータを1列...
-
GoogleスプレッドシートでA1に...
-
【Excel】版が同じ事を示す番号...
-
googleのスプレッドシート
-
重複しない値を取り出したい
-
教えていただければと思います ...
-
Lookup関数
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excelの警告について
-
Excelで数値を時間数に変換する...
-
エクセルの数式バーのフォント...
-
エクセルで数字の組み合わせを...
-
エクセルを使用して、円周率を...
-
Excelで特定の文字列が含まれて...
-
Excel 対象のセルに入力が無い...
-
任意の値が存在する行に名前を...
-
エクセルでファイルの最終更新...
-
index関数の説明をお願いします。
-
条件付き書式でやりたいのですが
-
重複しない値を取り出したい
-
【ExcelVBA】UTF-8(BOM無)でC...
-
【マクロ】マクロが割当てされ...
-
エクセル IF計算式?でしょうか?
-
エクセルで曜日を入れたい
-
表中の指定した条件の文字列を...
-
【Excel】版が同じ事を示す番号...
-
EXCELの散布図で日付が1900年に...
-
Excelについて。Excelに縦1列に...
おすすめ情報