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で質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) 列を自動で追加したい 3 2022/07/11 12:58
- Excel(エクセル) ExcelVBAでリストの項目に必要数と同じ手配数を分配していくマクロを作りたいです。 1 2022/07/29 18:36
- Excel(エクセル) 【困っています】VBA 追加処理の記述を教えてください。 1 2022/08/25 22:54
- Excel(エクセル) 【エクセル」 特定のセルで条件抽出した列を、別シートに上から詰めて表示したい。 8 2022/04/08 16:00
- Visual Basic(VBA) 列 A に同じ日が2つが必要です。 1 2023/03/28 07:25
- Visual Basic(VBA) Excel VBA マクロ ある列の最終行迄を参照し、別の列の空白セルに値を入力したいです 2 2023/03/05 02:44
- Excel(エクセル) 現在のセルの文字列を右隣のセルの名前にするマクロをつくりたい 4 2023/01/12 09:01
- Visual Basic(VBA) ファイル全てを .xlsm に変更したところ、プログラムが途中で落ちてしまっています 17 2022/12/07 12:03
- Excel(エクセル) 表内で、Enterキーで横→行の最後入力したら次の行の先頭に移動するマクロを作りたい 3 2022/05/01 21:19
- Visual Basic(VBA) vbaについて 主に以下のような設定をしたいです。 Aブックの表の行数が20未満だったら Bブックの 1 2023/06/08 23:40
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルでの作業計算方法について
-
Microsoft1Officeの互換ソフト...
-
【マクロ】その時、その時で変...
-
はがきについて。
-
【マクロ】読取専用のファイル...
-
エクセル初心者です 関数の入れ...
-
【関数】適切な文字数の数字を...
-
LOOKUP関数を使えばいいのでし...
-
【関数】先頭だけにある、半角...
-
Excel ピボットテーブルで日付...
-
Excelのpivotについて質問です
-
時間によってファイル名が変わ...
-
エクセル 白黒印刷で白線を印刷...
-
Aというブックの1というシート...
-
エクセル関数を教えてください
-
WPS OFFICEでの縦書きについて
-
Excelのチェックボックスの使い...
-
エクセルの条件付き書式につい...
-
エクセルのセルに同じ大きさの...
-
エクセルの関数について教えて...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel 2019 のピボットテーブル...
-
[関数得意な方]教えて下さい・...
-
Excelにてある膨大なデータを管...
-
[関数について]わかる方教えて...
-
Excel初心者です。 詳しい方、...
-
excelの不要な行の削除ができな...
-
エクセル関数に詳しい方教えて...
-
INDIRECTを使わず excelで複数...
-
[オートフィルタ]で抽出された...
-
エクセルの神よ、ご回答を! エ...
-
エクセル関数に詳しい方、教え...
-
各ページの1番上の表示について
-
Excelで写真のような表を作った...
-
エクセルで不等号記号(≠)が上に...
-
数学 Tan(θ)-1/Cos(θ)について...
-
Excel 2019 は、SPILL機能があ...
-
Excelで全角を半角にしたいので...
-
条件付き書式を教えてください
-
Excel フィルターを掛けた状態...
-
[オートフィルタ]の適用範囲の...
おすすめ情報