回答編集履歴

5

修正

2020/01/22 10:38

投稿

mattuwan
mattuwan

スコア2136

test CHANGED
@@ -1,687 +1,537 @@
1
- う~ん。
2
-
3
- なんで、エセル備わっている機能で出来ることを
4
-
5
- 自作してるのですか?
6
-
7
-
8
-
9
- 「表」と言われている形の「クロス集計表」は、
10
-
11
- 「ピボットテーブル」という機能でデータのシートから、
12
-
13
- 作成可能です。
14
-
15
- 作業用のシートにそれを手動で設定しておけば、
16
-
17
- マクロでするとは、
18
-
19
- 1)データの参照範囲を再設定
20
-
21
- 2)ピボットテーブルの更新
22
-
23
- 3)結果を見せるシートにコピペして好みの形に再編集
24
-
25
- ぐらいになると思いますがどうでしょうか?
26
-
27
-
1
+ 例えば、
2
+
3
+ 自ブッ(マクロを仕込むブック)に、
4
+
5
+ 日報
6
+
7
+ 集計表
8
+
9
+ 作業用
10
+
11
+ 3つのシートがあるとします。
12
+
13
+ そして日報シートに、
14
+
15
+
16
+
17
+ ```こに言語を入力
18
+
19
+ 日付 場所 氏名 執務時間
20
+
21
+
22
+
23
+ 2020.7.1 事務所 織田 信長 7
24
+
25
+
26
+
27
+ 2020.7.5 事務所 明智 光秀 2.5
28
+
29
+
30
+
31
+ 2020.7.9 本社 織田 信長 3.5
32
+
33
+
34
+
35
+ 2020.7.13 本社 千 利休 1
36
+
37
+
38
+
39
+ 2020.7.17 本社 徳川 家康 5
40
+
41
+
42
+
43
+ 2020.7.21 子会社 武田 信玄 7
44
+
45
+
46
+
47
+ 2020.7.25 支店・営業所 織田 信長 2.5
48
+
49
+
50
+
51
+ 2020.7.29 事務所 明智 光秀 3.5
52
+
53
+
54
+
55
+ 2020.8.2 事務所 織田 信長 1
56
+
57
+
58
+
59
+ 2020.8.6 事務所 千 利休 5
60
+
61
+
62
+
63
+ 2020.8.10 本社 徳川 家康 7
64
+
65
+
66
+
67
+ 2020.8.14 本社 武田 信玄 2.5
68
+
69
+
70
+
71
+ 2020.8.18 本社 織田 信長 3.5
72
+
73
+
74
+
75
+ 2020.8.22 子会社 明智 光秀 1
76
+
77
+
78
+
79
+ 2020.8.26 支店・営業所 織田 信長 5
80
+
81
+
82
+
83
+ 2020.8.30 本社 千 利休 7
84
+
85
+
86
+
87
+ 2020.9.3 子会社 徳川 家康 2.5
88
+
89
+
90
+
91
+ 2020.9.7 支店・営業所 武田 信玄 3.5
92
+
93
+ ```
94
+
95
+
96
+
97
+ というようなデータがあるとして、
98
+
99
+
100
+
101
+ 以下のようなコードで、
102
+
103
+ 自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
104
+
105
+ あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。
106
+
107
+
108
+
109
+ 他人が書いたコードは解読するのに苦労するとは思いますが、
110
+
111
+ 参考になれば。
112
+
113
+
114
+
115
+ 参考サイト>>
116
+
117
+ [構造化プログラミングに挑戦しよう!](http://home.att.ne.jp/zeta/gen/excel/c03p06.htm)
118
+
119
+ [仕様要件からコードの組み立てを考える。](http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_160.html)
120
+
121
+
122
+
123
+ 他にもいいサイトがある気がします。
124
+
125
+ 探してみてください。
126
+
127
+ ※文字数制限に引っかかったため、一部削除しました。
28
128
 
29
129
  ---
30
130
 
31
- ②について
32
-
33
- 上に書きましたが、自作するよりエクセル君が出来ることは、
34
-
35
- エクセル君に任た方が処理が速い場合が多いです
36
-
37
- 意図が通じて無いようですが、
38
-
39
- 事前にピボットテーブルを設定したファイルを配布するのですから、
40
-
41
- ユーザーがピボットテーブルを触ることはありません。
42
-
43
- マクロで自動でやてもらうよう指示するだけです。
44
-
45
-
46
-
47
- ③について、
48
-
49
- >1行空けて
50
-
51
- with worksheets("?").usedrange
52
-
53
- .offset(.rows.count+2).cells(1)
54
-
55
- end with
56
-
57
-
58
-
59
- ↑が貼付先のセルになると思います。
60
-
61
-
62
-
63
- >列幅を揃える
64
-
65
- エクセルにまかせていいなら、
66
-
67
-
68
-
69
- worksheets("?").usedrange.entirecolumn.autofit
70
-
71
-
72
-
73
- 各列に既定の幅を設定するなら、
74
-
75
- 各列毎に設定してください。
76
-
77
- コードはマクロの記録で探ることが可能だと思います。
78
-
79
-
80
-
81
- ④について
82
-
83
- ピボットテーブルというのはまさにこういう表を作るための機能なので、
84
-
85
- それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
86
-
87
- 関数も作成可能です。
88
-
89
- 表の縦横の項目名を参照して、合計するなら、
90
-
91
- Sumifs関数が使えます。
92
-
93
- [SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)
94
-
95
-
96
-
97
- 当然マクロで一から作ることも可能ですが、
98
-
99
- 処理速度はデータ数が多くなるほど処理が重くなると思います。
100
-
101
- が、全然できないよりは出来た方がいいとおもいます。
102
-
103
- が、テーマがたくさんあると、見る人が何に困っているかわかりずらいの
104
-
105
- 別途質問してはいかがでしょうか?
106
-
107
-
108
-
109
- ---
110
-
111
- > ②について教えて頂きたいのですが様式の表のように「場所+時間」を
112
-
113
- > ピポッドで表示するにはどうのようにしたらよいのでしょうか?
114
-
115
-
116
-
117
- 「場所」は列ラベルでは?
118
-
119
-
120
-
121
- ![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
122
-
123
-
124
-
125
- ---
126
-
127
- > 表の様式は管理上変更できません。
128
-
129
- >
130
-
131
- > 表の様式をピポッドで成する方法がありましたら教えて下さい。
132
-
133
-
134
-
135
- う~ん。。。
136
-
137
- ピボットテーブルで集計し、それをご自分の好きなように表示するよう加工することになります。
138
-
139
-
140
-
141
- 例えば、
142
-
143
- 自ブク(マクロを仕込むック)に、
144
-
145
- 日報
146
-
147
- 集計表
148
-
149
- 作業用
150
-
151
- 3つのシートがあるとします。
152
-
153
- そして日報シートに、
154
-
155
-
156
-
157
- ```ここに言語を入力
158
-
159
- 日付 場所 氏名 執務時間
160
-
161
-
162
-
163
- 2020.7.1 事務所 織田 信長 7
164
-
165
-
166
-
167
- 2020.7.5 事務所 明智 光秀 2.5
168
-
169
-
170
-
171
- 2020.7.9 本社 織田 信長 3.5
172
-
173
-
174
-
175
- 2020.7.13 本社 千 利休 1
176
-
177
-
178
-
179
- 2020.7.17 本社 徳川 家康 5
180
-
181
-
182
-
183
- 2020.7.21 子会社 武田 信玄 7
184
-
185
-
186
-
187
- 2020.7.25 支店・営業所 織田 信長 2.5
188
-
189
-
190
-
191
- 2020.7.29 事務所 明智 光秀 3.5
192
-
193
-
194
-
195
- 2020.8.2 事務所 織田 信長 1
196
-
197
-
198
-
199
- 2020.8.6 事務所 千 利休 5
200
-
201
-
202
-
203
- 2020.8.10 本社 徳川 家康 7
204
-
205
-
206
-
207
- 2020.8.14 本社 武田 信玄 2.5
208
-
209
-
210
-
211
- 2020.8.18 本社 織田 信長 3.5
212
-
213
-
214
-
215
- 2020.8.22 子会社 明智 光秀 1
216
-
217
-
218
-
219
- 2020.8.26 支店・営業所 織田 信長 5
220
-
221
-
222
-
223
- 2020.8.30 本社 千 利休 7
224
-
225
-
226
-
227
- 2020.9.3 子会社 徳川 家康 2.5
228
-
229
-
230
-
231
- 2020.9.7 支店・営業所 武田 信玄 3.5
131
+ コードを修正しました。
132
+
133
+ コンパイルはしてみましたが、
134
+
135
+ 動作確認はしてま
136
+
137
+ 参考になれば。
138
+
139
+
140
+
141
+ ```ExcelVBA
142
+
143
+ 'ピボットテーブルを使た集計サンプル Ver.0.90
144
+
145
+ Option Explicit
146
+
147
+
148
+
149
+ Sub メイン()
150
+
151
+ Dim wshData As Worksheet
152
+
153
+ Dim wshResult As Worksheet
154
+
155
+
156
+
157
+ Set wshData = Worksheets("日報")
158
+
159
+ Set wshResult = Worksheets("集計")
160
+
161
+ 集計 wshData, wshResult, "日付", "氏名,場所"
162
+
163
+ 集計 wshData, wshResult, "場所", "氏名", False
164
+
165
+ End Sub
166
+
167
+
168
+
169
+ Private Sub 集計( _
170
+
171
+ ByRef wshOld As Worksheet, _
172
+
173
+ ByRef wshNew As Worksheet, _
174
+
175
+ ByVal strSideItem As String, _
176
+
177
+ ByVal strTopItem As String, _
178
+
179
+ Optional ByVal flg As Boolean = True)
180
+
181
+ Dim rngTopleft As Range
182
+
183
+ Dim pvtMyTable As PivotTable
184
+
185
+
186
+
187
+ 'ピボットテーブル集計
188
+
189
+ Set pvtMyTable = GetResult(wshOld, strSideItem, strTopItem)
190
+
191
+ '書き出し位置の取得
192
+
193
+ Set rngTopleft = GetTopLeft(wshNew, flg)
194
+
195
+ '集計結果を様式に沿って出力
196
+
197
+ ResultOutput pvtMyTable, rngTopleft, flg
198
+
199
+ End Sub
200
+
201
+
202
+
203
+ 'ピボットテーブル集計
204
+
205
+ Private Function GetResult( _
206
+
207
+ ByRef wshSource As Worksheet, _
208
+
209
+ ByVal strSideItem As String, _
210
+
211
+ ByVal strTopItem As String) As PivotTable
212
+
213
+ Dim pvtCache As PivotCache
214
+
215
+ Dim pvtTable As PivotTable
216
+
217
+ Dim f As PivotField
218
+
219
+ Dim rngSourceData As Range
220
+
221
+ Dim rngWorkCellRange As Range
222
+
223
+ Dim v As Variant
224
+
225
+ Dim wsh As Workbook
226
+
227
+
228
+
229
+ 'セル範囲、ピボットテーブルの取得
230
+
231
+ Set wsh = ThisWorkbook.Worksheets("業用")
232
+
233
+ Set rngSourceData = wshSource.UsedRange
234
+
235
+ On Error GoTo ErrHandler
236
+
237
+ Set pvtTable = wsh.PivotTables(1)
238
+
239
+ On Error GoTo 0
240
+
241
+
242
+
243
+ 'ピボトテールでの集計
244
+
245
+ With pvtTable
246
+
247
+ '初期化
248
+
249
+ .ClearTable
250
+
251
+ '項目配置
252
+
253
+ .PivotFields(strSideItem).Orientation = xlRowField
254
+
255
+ For Each v In Split(strTopItem, ",")
256
+
257
+ .PivotFields(v).Orientation = xlColumnField
258
+
259
+ Next
260
+
261
+ .AddDataField .PivotFields("執務時間")
262
+
263
+ '小計行の非表示化
264
+
265
+ For Each f In .PivotFields
266
+
267
+ f.Subtotals(1) = False
268
+
269
+ Next
270
+
271
+ End With
272
+
273
+
274
+
275
+ '返り値のセット
276
+
277
+ Set GetResult = pvtTable
278
+
279
+
280
+
281
+ Exit Function
282
+
283
+
284
+
285
+ 'エラー回避処理(ピボットテーブルがシート上に未作成の場合は新規に作成)
286
+
287
+ ErrHandler:
288
+
289
+ Set pvtCache = wsh.Parent.PivotCaches.Create( _
290
+
291
+ SourceType:=xlDatabase, _
292
+
293
+ SourceData:=rngSourceData)
294
+
295
+ Set rngWorkCellRange = wsh.Range("A1")
296
+
297
+ Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
298
+
299
+ Resume Next
300
+
301
+ End Function
302
+
303
+
304
+
305
+ '書出し位置の取得
306
+
307
+ Private Function GetTopLeft( _
308
+
309
+ ByRef wsh As Worksheet, _
310
+
311
+ ByVal flg As Boolean) As Range
312
+
313
+ Dim c As Range
314
+
315
+
316
+
317
+ With wsh.UsedRange
318
+
319
+ If flg Then
320
+
321
+ .Clear
322
+
323
+ Set c = .Cells(1)
324
+
325
+ Else
326
+
327
+ Set c = .Cells(Rows.Count + 1, 1)
328
+
329
+ End If
330
+
331
+ End With
332
+
333
+ Set GetTopLeft = c
334
+
335
+ End Function
336
+
337
+
338
+
339
+ '集計結果を様式に沿って出力
340
+
341
+ Private Sub ResultOutput( _
342
+
343
+ ByRef pvtTable As PivotTable, _
344
+
345
+ ByRef rngCopyTo As Range, _
346
+
347
+ ByVal flg As Boolean)
348
+
349
+
350
+
351
+ '表頭の作成
352
+
353
+ If flg Then
354
+
355
+ Set表頭 pvtTable.TableRange1.Rows(2), rngCopyTo
356
+
357
+ End If
358
+
359
+ '表側の作成
360
+
361
+ Set表側 pvtTable.RowRange, rngCopyTo.Offset(1)
362
+
363
+ '表体の作成
364
+
365
+ Set表体 pvtTable.DataBodyRange, rngCopyTo.Offset(1, 1), flg
366
+
367
+
368
+
369
+ '列幅をオートフィット
370
+
371
+ rngCopyTo.CurrentRegion.EntireColumn.AutoFit
372
+
373
+ End Sub
374
+
375
+
376
+
377
+ '*******************************************
378
+
379
+ '表頭の作成
380
+
381
+ '第一引数 rngFrom:転記元のセル範囲(Range)
382
+
383
+ '第二引数 rngTo:転記先のセル範囲(Range)
384
+
385
+ '******************************************
386
+
387
+ Private Sub Set表頭(ByRef rngFrom As Range, ByRef rngTo As Range)
388
+
389
+ Dim v As Variant
390
+
391
+ Dim ix As Long
392
+
393
+
394
+
395
+ '元のセル範囲の値を一次配列で取得
396
+
397
+ '(ワークシート上の関数はセル範囲を与える仕様だが、
398
+
399
+ '配列も受け取れる関数があるので値(Value)を与えてもよい。)
400
+
401
+ With WorksheetFunction
402
+
403
+ v = .Transpose(.Transpose(rngFrom.Cells))
404
+
405
+ End With
406
+
407
+
408
+
409
+ 'それぞれの値の加工
410
+
411
+ For ix = LBound(v) To UBound(v)
412
+
413
+ If ix = 1 Then
414
+
415
+ v(ix) = "日付"
416
+
417
+ Else
418
+
419
+ '空白でないなら
420
+
421
+ If Len(v(ix)) > 0 Then
422
+
423
+ 'スペース文字で文字列を分割し最初の値を再設定
424
+
425
+ v(ix) = Split(v(ix), " ")(0)
426
+
427
+ End If
428
+
429
+ End If
430
+
431
+ Next
432
+
433
+ 'シート上へ転記
434
+
435
+ With rngTo.Resize(, rngFrom.Columns.Count)
436
+
437
+ .Value = v
438
+
439
+ '選択範囲内で中央に配置の設定
440
+
441
+ .HorizontalAlignment = xlCenterAcrossSelection
442
+
443
+ End With
444
+
445
+ End Sub
446
+
447
+
448
+
449
+ '******************************
450
+
451
+ '表側の作成
452
+
453
+ '***********************
454
+
455
+ Private Sub Set表側(ByRef rngFrom As Range, ByRef rngTo As Range)
456
+
457
+ rngTo.Resize(rngFrom.Rows.Count - 1).Value = rngFrom.Offset(1).Value
458
+
459
+ End Sub
460
+
461
+
462
+
463
+ '**********************************
464
+
465
+ '表体の作成
466
+
467
+ '第一引数 rngFrom:転記元セル範囲(Range)
468
+
469
+ '第二引数 rngTo:転記先セル範囲(Range)
470
+
471
+ '第三引数 flg:データに項目(略称)を付加するかどうかのフラグ(Boolean)
472
+
473
+ '*************************************
474
+
475
+ Private Sub Set表体(ByRef rngFrom As Range, _
476
+
477
+ ByRef rngTo As Range, _
478
+
479
+ ByVal flg As Boolean)
480
+
481
+ Dim vv As Variant
482
+
483
+ Dim v As Variant
484
+
485
+ Dim ixH As Long
486
+
487
+ Dim ixV As Long
488
+
489
+
490
+
491
+ '値を2次元配列変数で取得
492
+
493
+ vv = rngFrom.Value
494
+
495
+ '略称の付加
496
+
497
+ If flg Then
498
+
499
+ '略称の元を一次配列で取得
500
+
501
+ With WorksheetFunction
502
+
503
+ v = .Transpose(.Transpose(rngFrom.Rows(0).Cells))
504
+
505
+ End With
506
+
507
+ 'それぞれの値を巡回し、値に略称をくっつけていく
508
+
509
+ For ixH = LBound(vv, 1) To UBound(vv, 1)
510
+
511
+ For ixV = LBound(vv, 2) To UBound(vv, 2)
512
+
513
+ If IsEmpty(vv(ixH, ixV)) = False Then
514
+
515
+ vv(ixH, ixV) = Left(v(ixV), 1) & vv(ixH, ixV)
516
+
517
+ End If
518
+
519
+ Next
520
+
521
+ Next
522
+
523
+ End If
524
+
525
+ '転記先に転記
526
+
527
+ rngTo.Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Value = vv
528
+
529
+ End Sub
232
530
 
233
531
  ```
234
532
 
235
-
236
-
237
- というようなデータがあるとして、
238
-
239
-
240
-
241
- 以下のようなコードで、
242
-
243
- 自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
244
-
245
- あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。
246
-
247
-
248
-
249
- ```ExcelVBA
250
-
251
- '***********************
252
-
253
- 'ピボットテーブルを使った自分好みのクロス集計表を作成するサンプル
254
-
255
- '作成者:mattuwan
256
-
257
- '※著作権は放棄しますです。自己責任で使用・改変してください。
258
-
259
- '※エラー回避処理は万全ではないかもしれません。(バグがあるかも?)
260
-
261
- '*************************
262
-
263
- Option Explicit
264
-
265
-
266
-
267
- '********************************
268
-
269
- '集計表シートにクロス集計表を2つ作成
270
-
271
- '***********************************
272
-
273
- Sub Main()
274
-
275
- Dim rngWritingPosition As Range
276
-
277
-
278
-
279
- Set rngWritingPosition = Worksheets("集計表").Range("A1")
280
-
281
- Get表作成 "日付", "氏名,場所", rngWritingPosition
282
-
283
-
284
-
285
- With rngWritingPosition.CurrentRegion
286
-
287
- Set rngWritingPosition = .Cells(1).Offset(.Rows.Count)
288
-
289
- End With
290
-
291
- Get表作成 "場所", "氏名", rngWritingPosition, False
292
-
293
- End Sub
294
-
295
-
296
-
297
- '*************************************
298
-
299
- '表側及び表頭の項目を指定して集計し集計表の指定したセルに結果を挿入
300
-
301
- '第一引数 strSideItem:表側に使う項目(String)
302
-
303
- '第二引数 strTopItem:表頭に使う項目(複数指定する場合はカンマ区切りで指定)(String)
304
-
305
- '第三引数 rngTopLeft:表を作成するセル(左上)の位置を指定(Range)
306
-
307
- '第四引数 flg:表を作成するときにシートの初期化を行うか否かのフラグ(boolean)
308
-
309
- '返り値:作成した表のセル範囲
310
-
311
- '***********************************:
312
-
313
- Private Function Get表作成(ByVal strSideItem As String, _
314
-
315
- ByVal strTopItem As String, _
316
-
317
- ByRef rngTopLeft As Range, _
318
-
319
- Optional ByVal flg As Boolean = True) As Range
320
-
321
- Dim pvtTable As PivotTable
322
-
323
-
324
-
325
- 'シートの初期化
326
-
327
- If flg Then
328
-
329
- rngTopLeft.Worksheet.UsedRange.Clear
330
-
331
- End If
332
-
333
-
334
-
335
- 'ピボットテーブルで集計
336
-
337
- Set pvtTable = GetPvt集計(strSideItem, strTopItem)
338
-
339
-
340
-
341
- '集計結果を編集して集計用シートに集計表を作成
342
-
343
- Set集計表シートへ転記 rngTopLeft, pvtTable, flg
344
-
345
-
346
-
347
- '返り値のセット
348
-
349
- Set Get表作成 = rngTopLeft.CurrentRegion
350
-
351
- End Function
352
-
353
-
354
-
355
- '*********************************
356
-
357
- 'ピボットテーブルで集計
358
-
359
- '第一引数 strSideItem:表側の項目(String)
360
-
361
- '第二引数 strTopItem:表頭の項目(string)
362
-
363
- '返り値:設定したピボットテーブル
364
-
365
- '*****************************************
366
-
367
- Private Function GetPvt集計(ByVal strSideItem As String, _
368
-
369
- ByVal strTopItem As String) As PivotTable
370
-
371
- Dim pvtCache As PivotCache
372
-
373
- Dim pvtTable As PivotTable
374
-
375
- Dim f As PivotField
376
-
377
- Dim rngSourceData As Range
378
-
379
- Dim rngWorkCellRange As Range
380
-
381
- Dim v As Variant
382
-
383
- Dim wbk As Workbook
384
-
385
-
386
-
387
- 'セル範囲、ピボットテーブルの取得
388
-
389
- Set wbk = ThisWorkbook
390
-
391
- Set rngSourceData = wbk.Worksheets("日報").Range("A1").CurrentRegion
392
-
393
- On Error GoTo ErrHandler
394
-
395
- Set pvtTable = wbk.Worksheets("作業用").PivotTables(1)
396
-
397
- On Error GoTo 0
398
-
399
-
400
-
401
- 'ピボットテーブルでの集計
402
-
403
- With pvtTable
404
-
405
- '初期化
406
-
407
- .ClearTable
408
-
409
- '項目の配置
410
-
411
- .PivotFields(strSideItem).Orientation = xlRowField
412
-
413
- For Each v In Split(strTopItem, ",")
414
-
415
- .PivotFields(v).Orientation = xlColumnField
416
-
417
- Next
418
-
419
- .AddDataField .PivotFields("執務時間")
420
-
421
- '小計行の非表示化
422
-
423
- For Each f In .PivotFields
424
-
425
- f.Subtotals(1) = False
426
-
427
- Next
428
-
429
- End With
430
-
431
-
432
-
433
- '返り値のセット
434
-
435
- Set GetPvt集計 = pvtTable
436
-
437
- Exit Function
438
-
439
-
440
-
441
- 'エラー回避処理(ピボットテーブルがシート上に未作成の場合は新規に作成)
442
-
443
- ErrHandler:
444
-
445
- Set pvtCache = wbk.PivotCaches.Create( _
446
-
447
- SourceType:=xlDatabase, _
448
-
449
- SourceData:=rngSourceData)
450
-
451
- Set rngWorkCellRange = wbk.Worksheets("作業用").Range("A1")
452
-
453
- Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
454
-
455
- Resume Next
456
-
457
- End Function
458
-
459
-
460
-
461
- '**************************************
462
-
463
- 'ピボットテーブルでの集計結果を編集して集計表シートに集計表を作成
464
-
465
- '第一引数 rngCopyTo:作成するセルの位置(左上)(Range)
466
-
467
- '第二引数 pvtCopyFrom:集計表の元となるピボットテーブル(PivotTable)
468
-
469
- '第三引数 flg:シートを初期化したかどうかのフラグ、初期化されない場合は表頭を標記しない(Boolean)
470
-
471
- '***************************************
472
-
473
- Private Sub Set集計表シートへ転記(ByRef rngCopyTo As Range, _
474
-
475
- ByRef pvtCopyFrom As PivotTable, _
476
-
477
- ByVal flg As Boolean)
478
-
479
- '表頭の作成
480
-
481
- If flg Then
482
-
483
- Set表頭 pvtCopyFrom.TableRange1.Rows(2), rngCopyTo
484
-
485
- End If
486
-
487
- '表側の作成
488
-
489
- Set表側 pvtCopyFrom.RowRange, rngCopyTo.Offset(1)
490
-
491
- '表体の作成
492
-
493
- Set表体 pvtCopyFrom.DataBodyRange, rngCopyTo.Offset(1, 1), flg
494
-
495
-
496
-
497
- '列幅をオートフィット
498
-
499
- rngCopyTo.CurrentRegion.EntireColumn.AutoFit
500
-
501
- End Sub
502
-
503
-
504
-
505
- '**************************************
506
-
507
- '表頭の作成
508
-
509
- '第一引数 rngFrom:転記元のセル範囲(Range)
510
-
511
- '第二引数 rngTo:転記先のセル範囲(Range)
512
-
513
- '******************************************
514
-
515
- Private Sub Set表頭(ByRef rngFrom As Range, ByRef rngTo As Range)
516
-
517
- Dim v As Variant
518
-
519
- Dim ix As Long
520
-
521
-
522
-
523
- '元のセル範囲の値を一次配列で取得
524
-
525
- '(ワークシート上の関数はセル範囲を与える仕様だが、
526
-
527
- '配列も受け取れる関数があるので値(Value)を与えてもよい。)
528
-
529
- With WorksheetFunction
530
-
531
- v = .Transpose(.Transpose(rngFrom.Cells))
532
-
533
- End With
534
-
535
-
536
-
537
- 'それぞれの値の加工
538
-
539
- For ix = LBound(v) To UBound(v)
540
-
541
- If ix = 1 Then
542
-
543
- v(ix) = "日付"
544
-
545
- Else
546
-
547
- '空白でないなら
548
-
549
- If Len(v(ix)) > 0 Then
550
-
551
- 'スペース文字で文字列を分割し最初の値を再設定
552
-
553
- v(ix) = Split(v(ix), " ")(0)
554
-
555
- End If
556
-
557
- End If
558
-
559
- Next
560
-
561
- 'シート上へ転記
562
-
563
- With rngTo.Resize(, rngFrom.Columns.Count)
564
-
565
- .Value = v
566
-
567
- '選択範囲内で中央に配置の設定
568
-
569
- .HorizontalAlignment = xlCenterAcrossSelection
570
-
571
- End With
572
-
573
- End Sub
574
-
575
-
576
-
577
- '******************************
578
-
579
- '表側の作成
580
-
581
- '***********************
582
-
583
- Private Sub Set表側(ByRef rngFrom As Range, ByRef rngTo As Range)
584
-
585
- rngTo.Resize(rngFrom.Rows.Count - 1).Value = rngFrom.Offset(1).Value
586
-
587
- End Sub
588
-
589
-
590
-
591
- '**********************************
592
-
593
- '表体の作成
594
-
595
- '第一引数 rngFrom:転記元セル範囲(Range)
596
-
597
- '第二引数 rngTo:転記先セル範囲(Range)
598
-
599
- '第三引数 flg:データに項目(略称)を付加するかどうかのフラグ(Boolean)
600
-
601
- '*************************************
602
-
603
- Private Sub Set表体(ByRef rngFrom As Range, _
604
-
605
- ByRef rngTo As Range, _
606
-
607
- ByVal flg As Boolean)
608
-
609
- Dim vv As Variant
610
-
611
- Dim v As Variant
612
-
613
- Dim ixH As Long
614
-
615
- Dim ixV As Long
616
-
617
-
618
-
619
- '値を2次元配列変数で取得
620
-
621
- vv = rngFrom.Value
622
-
623
- '略称の付加
624
-
625
- If flg Then
626
-
627
- '略称の元を一次配列で取得
628
-
629
- With WorksheetFunction
630
-
631
- v = .Transpose(.Transpose(rngFrom.Rows(0).Cells))
632
-
633
- End With
634
-
635
- 'それぞれの値を巡回し、値に略称をくっつけていく
636
-
637
- For ixH = LBound(vv, 1) To UBound(vv, 1)
638
-
639
- For ixV = LBound(vv, 2) To UBound(vv, 2)
640
-
641
- If IsEmpty(vv(ixH, ixV)) = False Then
642
-
643
- vv(ixH, ixV) = Left(v(ixV), 1) & vv(ixH, ixV)
644
-
645
- End If
646
-
647
- Next
648
-
649
- Next
650
-
651
- End If
652
-
653
- '転記先に転記
654
-
655
- rngTo.Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Value = vv
656
-
657
- End Sub
658
-
659
-
660
-
661
- '****************<プログラム終わり>***************************
662
-
663
- ```
664
-
665
- 時間がありそうなのでコメントを入れてみました。
666
-
667
-
668
-
669
- 他人が書いたコードは解読するのに苦労するとは思いますが、
670
-
671
- 参考になれば。
672
-
673
-
674
-
675
- 参考サイト>>
676
-
677
- [構造化プログラミングに挑戦よう!](http://home.att.ne.jp/zeta/gen/excel/c03p06.htm)
533
+ [売上集計ているExcelの動作を軽くしたい](https://teratail.com/questions/236682)
678
-
679
- [仕様要件からコードの組み立てを考える。](http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_160.html)
534
+
680
-
681
-
682
-
683
- 他にもいいサイトがある気がします。
535
+
684
-
685
- 探してみてください。
536
+
686
-
687
- ※文字数制限に引かかっため、一部削除しました。
537
+ ↑こちらもピボットテーブルを使った方法を提案しました。参考になれば。

4

追記

2020/01/22 10:38

投稿

mattuwan
mattuwan

スコア2136

test CHANGED
@@ -28,142 +28,106 @@
28
28
 
29
29
  ---
30
30
 
31
-
31
+ ②について
32
+
32
-
33
+ 上に書きましたが、自作するよりエクセル君が出来ることは、
34
+
35
+ エクセル君に任せた方が処理が速い場合が多いです。
36
+
37
+ 意図が通じて無いようですが、
38
+
39
+ 事前にピボットテーブルを設定したファイルを配布するのですから、
40
+
41
+ ユーザーがピボットテーブルを触ることはありません。
42
+
43
+ マクロで自動でやってもらうよう指示するだけです。
44
+
45
+
46
+
47
+ ③について、
48
+
49
+ >1行空けて
50
+
51
+ with worksheets("?").usedrange
52
+
53
+ .offset(.rows.count+2).cells(1)
54
+
55
+ end with
56
+
57
+
58
+
33
- > ① 4)エラーが出ます。
59
+ ↑が貼付先のセルなると思います。
60
+
61
+
62
+
34
-
63
+ >列幅を揃える
64
+
65
+ エクセルにまかせていいなら、
66
+
67
+
68
+
69
+ worksheets("?").usedrange.entirecolumn.autofit
70
+
71
+
72
+
73
+ 各列に既定の幅を設定するなら、
74
+
75
+ 各列毎に設定してください。
76
+
77
+ コードはマクロの記録で探ることが可能だと思います。
78
+
79
+
80
+
81
+ ④について
82
+
83
+ ピボットテーブルというのはまさにこういう表を作るための機能なので、
84
+
85
+ それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
86
+
87
+ 関数でも作成可能です。
88
+
89
+ 表の縦横の項目名を参照して、合計するなら、
90
+
91
+ Sumifs関数が使えます。
92
+
93
+ [SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る
94
+
95
+
96
+
97
+ 当然マクロで一から作ることも可能ですが、
98
+
99
+ 処理速度はデータ数が多くなるほど処理が重くなると思います。
100
+
101
+ が、全然できないよりは出来た方がいいとおもいます。
102
+
103
+ が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
104
+
105
+ 別途質問してはいかがでしょうか?
106
+
107
+
108
+
109
+ ---
110
+
111
+ > ②について教えて頂きたいのですが様式の表のように「場所+時間」を
112
+
35
- > 先月まではエラーはありませんでした。
113
+ > ピポッド表示するにどうのようにしたらよいのでしょうか?
114
+
115
+
116
+
36
-
117
+ 「場所」は列ラベルでは?
118
+
119
+
120
+
121
+ ![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
122
+
123
+
124
+
125
+ ---
126
+
37
- > 何が原因か分かりません。
127
+ > 表の様式は管理上変更できません。
38
128
 
39
129
  >
40
130
 
41
- >
42
-
43
- > 実行時エラー1004
44
-
45
- > アプリケーション定義またはオブジェクト定義のエラーです。
46
-
47
- >
48
-
49
- > .Add Type:=xlValidateList, _
50
-
51
- > AlertStyle:=xlValidAlertStop, _
52
-
53
- > Operator:=xlBetween, _
54
-
55
- > Formula1:="=名前リスト"
56
-
57
-
58
-
59
- 名前リストという名前の定義を消したのでは?
60
-
61
- オブジェクト定義というのは、
62
-
63
- 今回の場合、指定されたセル範囲(=Rangeオブジェクトと呼ぶ)が存在しない場合によく出ます。
64
-
65
-
66
-
67
- ②について
68
-
69
- 上に書きましたが、自作するよりエクセル君が出来ることは、
70
-
71
- エクセル君に任せた方が処理が速い場合が多いです。
72
-
73
- 意図が通じて無いようですが、
74
-
75
- 事前にピボットテーブルを設定したファイルを配布するのですから、
76
-
77
- ユーザーがピボットテーブルを触ることはありません。
78
-
79
- マクロで自動でやってもらうよう指示するだけです。
80
-
81
-
82
-
83
- ③について、
84
-
85
- >1行空けて
86
-
87
- with worksheets("?").usedrange
88
-
89
- .offset(.rows.count+2).cells(1)
90
-
91
- end with
92
-
93
-
94
-
95
- ↑が貼付先のセルになると思います。
96
-
97
-
98
-
99
- >列幅を揃える
100
-
101
- エクセルにまかせていいなら、
102
-
103
-
104
-
105
- worksheets("?").usedrange.entirecolumn.autofit
106
-
107
-
108
-
109
- 各列に既定の幅を設定するなら、
110
-
111
- 各列毎に設定してください。
112
-
113
- コードはマクロの記録で探ることが可能だと思います。
114
-
115
-
116
-
117
- ④について
118
-
119
- ピボットテーブルというのはまさにこういう表を作るための機能なので、
120
-
121
- それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
122
-
123
- 関数でも作成可能です。
124
-
125
- 表の縦横の項目名を参照して、合計するなら、
126
-
127
- Sumifs関数が使えます。
128
-
129
- [SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る
130
-
131
-
132
-
133
- 当然マクロで一から作ることも可能ですが、
134
-
135
- 処理速度はデータ数が多くなるほど処理が重くなると思います。
136
-
137
- が、全然できないよりは出来た方がいいとおもいます。
138
-
139
- が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
140
-
141
- 別途質問してはいかがでしょうか?
142
-
143
-
144
-
145
- ---
146
-
147
- > ②について教えて頂きたいのですが様式の表のように「場所+時間」を
148
-
149
- > ピポッドで表示するにはどうのようにしたらよいのでしょうか?
150
-
151
-
152
-
153
- 「場所」は列ラベルでは?
154
-
155
-
156
-
157
- ![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
158
-
159
-
160
-
161
- ---
162
-
163
- > 表の様式は管理上変更できません。
164
-
165
- >
166
-
167
131
  > 表の様式をピポッドで作成する方法がありましたら教えて下さい。
168
132
 
169
133
 
@@ -284,10 +248,28 @@
284
248
 
285
249
  ```ExcelVBA
286
250
 
251
+ '***********************
252
+
253
+ 'ピボットテーブルを使った自分好みのクロス集計表を作成するサンプル
254
+
255
+ '作成者:mattuwan
256
+
257
+ '※著作権は放棄しますです。自己責任で使用・改変してください。
258
+
259
+ '※エラー回避処理は万全ではないかもしれません。(バグがあるかも?)
260
+
261
+ '*************************
262
+
287
263
  Option Explicit
288
264
 
289
265
 
290
266
 
267
+ '********************************
268
+
269
+ '集計表シートにクロス集計表を2つ作成
270
+
271
+ '***********************************
272
+
291
273
  Sub Main()
292
274
 
293
275
  Dim rngWritingPosition As Range
@@ -312,38 +294,76 @@
312
294
 
313
295
 
314
296
 
297
+ '*************************************
298
+
299
+ '表側及び表頭の項目を指定して集計し集計表の指定したセルに結果を挿入
300
+
301
+ '第一引数 strSideItem:表側に使う項目(String)
302
+
303
+ '第二引数 strTopItem:表頭に使う項目(複数指定する場合はカンマ区切りで指定)(String)
304
+
305
+ '第三引数 rngTopLeft:表を作成するセル(左上)の位置を指定(Range)
306
+
307
+ '第四引数 flg:表を作成するときにシートの初期化を行うか否かのフラグ(boolean)
308
+
309
+ '返り値:作成した表のセル範囲
310
+
311
+ '***********************************:
312
+
315
313
  Private Function Get表作成(ByVal strSideItem As String, _
316
314
 
317
315
  ByVal strTopItem As String, _
318
316
 
319
317
  ByRef rngTopLeft As Range, _
320
318
 
321
- Optional flg As Boolean = True) As Range
319
+ Optional ByVal flg As Boolean = True) As Range
322
320
 
323
321
  Dim pvtTable As PivotTable
324
322
 
325
323
 
326
324
 
325
+ 'シートの初期化
326
+
327
327
  If flg Then
328
328
 
329
329
  rngTopLeft.Worksheet.UsedRange.Clear
330
330
 
331
331
  End If
332
332
 
333
+
334
+
333
-
335
+ 'ピボットテーブルで集計
334
336
 
335
337
  Set pvtTable = GetPvt集計(strSideItem, strTopItem)
336
338
 
339
+
340
+
341
+ '集計結果を編集して集計用シートに集計表を作成
342
+
337
343
  Set集計表シートへ転記 rngTopLeft, pvtTable, flg
338
344
 
339
345
 
340
346
 
347
+ '返り値のセット
348
+
341
349
  Set Get表作成 = rngTopLeft.CurrentRegion
342
350
 
343
351
  End Function
344
352
 
345
353
 
346
354
 
355
+ '*********************************
356
+
357
+ 'ピボットテーブルで集計
358
+
359
+ '第一引数 strSideItem:表側の項目(String)
360
+
361
+ '第二引数 strTopItem:表頭の項目(string)
362
+
363
+ '返り値:設定したピボットテーブル
364
+
365
+ '*****************************************
366
+
347
367
  Private Function GetPvt集計(ByVal strSideItem As String, _
348
368
 
349
369
  ByVal strTopItem As String) As PivotTable
@@ -364,6 +384,8 @@
364
384
 
365
385
 
366
386
 
387
+ 'セル範囲、ピボットテーブルの取得
388
+
367
389
  Set wbk = ThisWorkbook
368
390
 
369
391
  Set rngSourceData = wbk.Worksheets("日報").Range("A1").CurrentRegion
@@ -376,10 +398,16 @@
376
398
 
377
399
 
378
400
 
401
+ 'ピボットテーブルでの集計
402
+
379
403
  With pvtTable
380
404
 
405
+ '初期化
406
+
381
407
  .ClearTable
382
408
 
409
+ '項目の配置
410
+
383
411
  .PivotFields(strSideItem).Orientation = xlRowField
384
412
 
385
413
  For Each v In Split(strTopItem, ",")
@@ -390,6 +418,8 @@
390
418
 
391
419
  .AddDataField .PivotFields("執務時間")
392
420
 
421
+ '小計行の非表示化
422
+
393
423
  For Each f In .PivotFields
394
424
 
395
425
  f.Subtotals(1) = False
@@ -398,12 +428,18 @@
398
428
 
399
429
  End With
400
430
 
431
+
432
+
433
+ '返り値のセット
434
+
401
435
  Set GetPvt集計 = pvtTable
402
436
 
403
437
  Exit Function
404
438
 
405
439
 
406
440
 
441
+ 'エラー回避処理(ピボットテーブルがシート上に未作成の場合は新規に作成)
442
+
407
443
  ErrHandler:
408
444
 
409
445
  Set pvtCache = wbk.PivotCaches.Create( _
@@ -422,28 +458,60 @@
422
458
 
423
459
 
424
460
 
461
+ '**************************************
462
+
463
+ 'ピボットテーブルでの集計結果を編集して集計表シートに集計表を作成
464
+
465
+ '第一引数 rngCopyTo:作成するセルの位置(左上)(Range)
466
+
467
+ '第二引数 pvtCopyFrom:集計表の元となるピボットテーブル(PivotTable)
468
+
469
+ '第三引数 flg:シートを初期化したかどうかのフラグ、初期化されない場合は表頭を標記しない(Boolean)
470
+
471
+ '***************************************
472
+
425
473
  Private Sub Set集計表シートへ転記(ByRef rngCopyTo As Range, _
426
474
 
427
475
  ByRef pvtCopyFrom As PivotTable, _
428
476
 
429
477
  ByVal flg As Boolean)
430
478
 
479
+ '表頭の作成
480
+
431
481
  If flg Then
432
482
 
433
483
  Set表頭 pvtCopyFrom.TableRange1.Rows(2), rngCopyTo
434
484
 
435
485
  End If
436
486
 
487
+ '表側の作成
488
+
437
489
  Set表側 pvtCopyFrom.RowRange, rngCopyTo.Offset(1)
438
490
 
491
+ '表体の作成
492
+
439
493
  Set表体 pvtCopyFrom.DataBodyRange, rngCopyTo.Offset(1, 1), flg
440
494
 
495
+
496
+
497
+ '列幅をオートフィット
498
+
441
499
  rngCopyTo.CurrentRegion.EntireColumn.AutoFit
442
500
 
443
501
  End Sub
444
502
 
445
503
 
446
504
 
505
+ '**************************************
506
+
507
+ '表頭の作成
508
+
509
+ '第一引数 rngFrom:転記元のセル範囲(Range)
510
+
511
+ '第二引数 rngTo:転記先のセル範囲(Range)
512
+
513
+ '******************************************
514
+
447
515
  Private Sub Set表頭(ByRef rngFrom As Range, ByRef rngTo As Range)
448
516
 
449
517
  Dim v As Variant
@@ -452,12 +520,22 @@
452
520
 
453
521
 
454
522
 
523
+ '元のセル範囲の値を一次配列で取得
524
+
525
+ '(ワークシート上の関数はセル範囲を与える仕様だが、
526
+
527
+ '配列も受け取れる関数があるので値(Value)を与えてもよい。)
528
+
455
529
  With WorksheetFunction
456
530
 
457
531
  v = .Transpose(.Transpose(rngFrom.Cells))
458
532
 
459
533
  End With
460
534
 
535
+
536
+
537
+ 'それぞれの値の加工
538
+
461
539
  For ix = LBound(v) To UBound(v)
462
540
 
463
541
  If ix = 1 Then
@@ -466,8 +544,12 @@
466
544
 
467
545
  Else
468
546
 
547
+ '空白でないなら
548
+
469
549
  If Len(v(ix)) > 0 Then
470
550
 
551
+ 'スペース文字で文字列を分割し最初の値を再設定
552
+
471
553
  v(ix) = Split(v(ix), " ")(0)
472
554
 
473
555
  End If
@@ -476,10 +558,14 @@
476
558
 
477
559
  Next
478
560
 
561
+ 'シート上へ転記
562
+
479
563
  With rngTo.Resize(, rngFrom.Columns.Count)
480
564
 
481
565
  .Value = v
482
566
 
567
+ '選択範囲内で中央に配置の設定
568
+
483
569
  .HorizontalAlignment = xlCenterAcrossSelection
484
570
 
485
571
  End With
@@ -488,6 +574,12 @@
488
574
 
489
575
 
490
576
 
577
+ '******************************
578
+
579
+ '表側の作成
580
+
581
+ '***********************
582
+
491
583
  Private Sub Set表側(ByRef rngFrom As Range, ByRef rngTo As Range)
492
584
 
493
585
  rngTo.Resize(rngFrom.Rows.Count - 1).Value = rngFrom.Offset(1).Value
@@ -496,6 +588,18 @@
496
588
 
497
589
 
498
590
 
591
+ '**********************************
592
+
593
+ '表体の作成
594
+
595
+ '第一引数 rngFrom:転記元セル範囲(Range)
596
+
597
+ '第二引数 rngTo:転記先セル範囲(Range)
598
+
599
+ '第三引数 flg:データに項目(略称)を付加するかどうかのフラグ(Boolean)
600
+
601
+ '*************************************
602
+
499
603
  Private Sub Set表体(ByRef rngFrom As Range, _
500
604
 
501
605
  ByRef rngTo As Range, _
@@ -512,17 +616,23 @@
512
616
 
513
617
 
514
618
 
619
+ '値を2次元配列変数で取得
620
+
515
621
  vv = rngFrom.Value
516
622
 
623
+ '略称の付加
624
+
517
625
  If flg Then
518
626
 
627
+ '略称の元を一次配列で取得
628
+
519
629
  With WorksheetFunction
520
630
 
521
- v = .Transpose(.Transpose(rngFrom.Rows(0)))
631
+ v = .Transpose(.Transpose(rngFrom.Rows(0).Cells))
522
632
 
523
633
  End With
524
634
 
525
-
635
+ 'それぞれの値を巡回し、値に略称をくっつけていく
526
636
 
527
637
  For ixH = LBound(vv, 1) To UBound(vv, 1)
528
638
 
@@ -540,28 +650,38 @@
540
650
 
541
651
  End If
542
652
 
653
+ '転記先に転記
654
+
543
655
  rngTo.Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Value = vv
544
656
 
545
657
  End Sub
546
658
 
659
+
660
+
661
+ '****************<プログラム終わり>***************************
662
+
547
663
  ```
548
664
 
665
+ 時間がありそうなのでコメントを入れてみました。
666
+
667
+
668
+
549
669
  他人が書いたコードは解読するのに苦労するとは思いますが、
550
670
 
551
671
  参考になれば。
552
672
 
673
+
674
+
675
+ 参考サイト>>
676
+
553
- ここまで一から書くのに僕の力量で、ヘルやオブジェクトブウザで調べながら
677
+ [構造化ログミングに挑戦しよう!](http://home.att.ne.jp/zeta/gen/excel/c03p06.htm)
678
+
554
-
679
+ [仕様要件からコードの組み立てを考える。](http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_160.html)
680
+
681
+
682
+
555
- 4時間くらいかかりした
683
+ 他にもいいサイトがある気がし
556
-
557
- ぜんぜん解らないところから始めるなら2週間~数か月かかるかも知れません。
684
+
558
-
559
- 解読してみてわからないところがあれば、
560
-
561
- も少ピンポイントで質問してください。
685
+ してみてください。
562
-
563
- どこから解説していいか解らないし、
686
+
564
-
565
- 全部解説してたら、どんだけ時間が掛かるかわからないし、
566
-
567
- 入門書1冊書けるくらいかかないといけないようになるので
687
+ ※文字数制限に引っかかったため、一部削除しました

3

追記

2020/01/18 09:25

投稿

mattuwan
mattuwan

スコア2136

test CHANGED
@@ -155,3 +155,413 @@
155
155
 
156
156
 
157
157
  ![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
158
+
159
+
160
+
161
+ ---
162
+
163
+ > 表の様式は管理上変更できません。
164
+
165
+ >
166
+
167
+ > 表の様式をピポッドで作成する方法がありましたら教えて下さい。
168
+
169
+
170
+
171
+ う~ん。。。
172
+
173
+ ピボットテーブルで集計し、それをご自分の好きなように表示するよう加工することになります。
174
+
175
+
176
+
177
+ 例えば、
178
+
179
+ 自ブック(マクロを仕込むブック)に、
180
+
181
+ 日報
182
+
183
+ 集計表
184
+
185
+ 作業用
186
+
187
+ の3つのシートがあるとします。
188
+
189
+ そして日報シートに、
190
+
191
+
192
+
193
+ ```ここに言語を入力
194
+
195
+ 日付 場所 氏名 執務時間
196
+
197
+
198
+
199
+ 2020.7.1 事務所 織田 信長 7
200
+
201
+
202
+
203
+ 2020.7.5 事務所 明智 光秀 2.5
204
+
205
+
206
+
207
+ 2020.7.9 本社 織田 信長 3.5
208
+
209
+
210
+
211
+ 2020.7.13 本社 千 利休 1
212
+
213
+
214
+
215
+ 2020.7.17 本社 徳川 家康 5
216
+
217
+
218
+
219
+ 2020.7.21 子会社 武田 信玄 7
220
+
221
+
222
+
223
+ 2020.7.25 支店・営業所 織田 信長 2.5
224
+
225
+
226
+
227
+ 2020.7.29 事務所 明智 光秀 3.5
228
+
229
+
230
+
231
+ 2020.8.2 事務所 織田 信長 1
232
+
233
+
234
+
235
+ 2020.8.6 事務所 千 利休 5
236
+
237
+
238
+
239
+ 2020.8.10 本社 徳川 家康 7
240
+
241
+
242
+
243
+ 2020.8.14 本社 武田 信玄 2.5
244
+
245
+
246
+
247
+ 2020.8.18 本社 織田 信長 3.5
248
+
249
+
250
+
251
+ 2020.8.22 子会社 明智 光秀 1
252
+
253
+
254
+
255
+ 2020.8.26 支店・営業所 織田 信長 5
256
+
257
+
258
+
259
+ 2020.8.30 本社 千 利休 7
260
+
261
+
262
+
263
+ 2020.9.3 子会社 徳川 家康 2.5
264
+
265
+
266
+
267
+ 2020.9.7 支店・営業所 武田 信玄 3.5
268
+
269
+ ```
270
+
271
+
272
+
273
+ というようなデータがあるとして、
274
+
275
+
276
+
277
+ 以下のようなコードで、
278
+
279
+ 自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
280
+
281
+ あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。
282
+
283
+
284
+
285
+ ```ExcelVBA
286
+
287
+ Option Explicit
288
+
289
+
290
+
291
+ Sub Main()
292
+
293
+ Dim rngWritingPosition As Range
294
+
295
+
296
+
297
+ Set rngWritingPosition = Worksheets("集計表").Range("A1")
298
+
299
+ Get表作成 "日付", "氏名,場所", rngWritingPosition
300
+
301
+
302
+
303
+ With rngWritingPosition.CurrentRegion
304
+
305
+ Set rngWritingPosition = .Cells(1).Offset(.Rows.Count)
306
+
307
+ End With
308
+
309
+ Get表作成 "場所", "氏名", rngWritingPosition, False
310
+
311
+ End Sub
312
+
313
+
314
+
315
+ Private Function Get表作成(ByVal strSideItem As String, _
316
+
317
+ ByVal strTopItem As String, _
318
+
319
+ ByRef rngTopLeft As Range, _
320
+
321
+ Optional flg As Boolean = True) As Range
322
+
323
+ Dim pvtTable As PivotTable
324
+
325
+
326
+
327
+ If flg Then
328
+
329
+ rngTopLeft.Worksheet.UsedRange.Clear
330
+
331
+ End If
332
+
333
+
334
+
335
+ Set pvtTable = GetPvt集計(strSideItem, strTopItem)
336
+
337
+ Set集計表シートへ転記 rngTopLeft, pvtTable, flg
338
+
339
+
340
+
341
+ Set Get表作成 = rngTopLeft.CurrentRegion
342
+
343
+ End Function
344
+
345
+
346
+
347
+ Private Function GetPvt集計(ByVal strSideItem As String, _
348
+
349
+ ByVal strTopItem As String) As PivotTable
350
+
351
+ Dim pvtCache As PivotCache
352
+
353
+ Dim pvtTable As PivotTable
354
+
355
+ Dim f As PivotField
356
+
357
+ Dim rngSourceData As Range
358
+
359
+ Dim rngWorkCellRange As Range
360
+
361
+ Dim v As Variant
362
+
363
+ Dim wbk As Workbook
364
+
365
+
366
+
367
+ Set wbk = ThisWorkbook
368
+
369
+ Set rngSourceData = wbk.Worksheets("日報").Range("A1").CurrentRegion
370
+
371
+ On Error GoTo ErrHandler
372
+
373
+ Set pvtTable = wbk.Worksheets("作業用").PivotTables(1)
374
+
375
+ On Error GoTo 0
376
+
377
+
378
+
379
+ With pvtTable
380
+
381
+ .ClearTable
382
+
383
+ .PivotFields(strSideItem).Orientation = xlRowField
384
+
385
+ For Each v In Split(strTopItem, ",")
386
+
387
+ .PivotFields(v).Orientation = xlColumnField
388
+
389
+ Next
390
+
391
+ .AddDataField .PivotFields("執務時間")
392
+
393
+ For Each f In .PivotFields
394
+
395
+ f.Subtotals(1) = False
396
+
397
+ Next
398
+
399
+ End With
400
+
401
+ Set GetPvt集計 = pvtTable
402
+
403
+ Exit Function
404
+
405
+
406
+
407
+ ErrHandler:
408
+
409
+ Set pvtCache = wbk.PivotCaches.Create( _
410
+
411
+ SourceType:=xlDatabase, _
412
+
413
+ SourceData:=rngSourceData)
414
+
415
+ Set rngWorkCellRange = wbk.Worksheets("作業用").Range("A1")
416
+
417
+ Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
418
+
419
+ Resume Next
420
+
421
+ End Function
422
+
423
+
424
+
425
+ Private Sub Set集計表シートへ転記(ByRef rngCopyTo As Range, _
426
+
427
+ ByRef pvtCopyFrom As PivotTable, _
428
+
429
+ ByVal flg As Boolean)
430
+
431
+ If flg Then
432
+
433
+ Set表頭 pvtCopyFrom.TableRange1.Rows(2), rngCopyTo
434
+
435
+ End If
436
+
437
+ Set表側 pvtCopyFrom.RowRange, rngCopyTo.Offset(1)
438
+
439
+ Set表体 pvtCopyFrom.DataBodyRange, rngCopyTo.Offset(1, 1), flg
440
+
441
+ rngCopyTo.CurrentRegion.EntireColumn.AutoFit
442
+
443
+ End Sub
444
+
445
+
446
+
447
+ Private Sub Set表頭(ByRef rngFrom As Range, ByRef rngTo As Range)
448
+
449
+ Dim v As Variant
450
+
451
+ Dim ix As Long
452
+
453
+
454
+
455
+ With WorksheetFunction
456
+
457
+ v = .Transpose(.Transpose(rngFrom.Cells))
458
+
459
+ End With
460
+
461
+ For ix = LBound(v) To UBound(v)
462
+
463
+ If ix = 1 Then
464
+
465
+ v(ix) = "日付"
466
+
467
+ Else
468
+
469
+ If Len(v(ix)) > 0 Then
470
+
471
+ v(ix) = Split(v(ix), " ")(0)
472
+
473
+ End If
474
+
475
+ End If
476
+
477
+ Next
478
+
479
+ With rngTo.Resize(, rngFrom.Columns.Count)
480
+
481
+ .Value = v
482
+
483
+ .HorizontalAlignment = xlCenterAcrossSelection
484
+
485
+ End With
486
+
487
+ End Sub
488
+
489
+
490
+
491
+ Private Sub Set表側(ByRef rngFrom As Range, ByRef rngTo As Range)
492
+
493
+ rngTo.Resize(rngFrom.Rows.Count - 1).Value = rngFrom.Offset(1).Value
494
+
495
+ End Sub
496
+
497
+
498
+
499
+ Private Sub Set表体(ByRef rngFrom As Range, _
500
+
501
+ ByRef rngTo As Range, _
502
+
503
+ ByVal flg As Boolean)
504
+
505
+ Dim vv As Variant
506
+
507
+ Dim v As Variant
508
+
509
+ Dim ixH As Long
510
+
511
+ Dim ixV As Long
512
+
513
+
514
+
515
+ vv = rngFrom.Value
516
+
517
+ If flg Then
518
+
519
+ With WorksheetFunction
520
+
521
+ v = .Transpose(.Transpose(rngFrom.Rows(0)))
522
+
523
+ End With
524
+
525
+
526
+
527
+ For ixH = LBound(vv, 1) To UBound(vv, 1)
528
+
529
+ For ixV = LBound(vv, 2) To UBound(vv, 2)
530
+
531
+ If IsEmpty(vv(ixH, ixV)) = False Then
532
+
533
+ vv(ixH, ixV) = Left(v(ixV), 1) & vv(ixH, ixV)
534
+
535
+ End If
536
+
537
+ Next
538
+
539
+ Next
540
+
541
+ End If
542
+
543
+ rngTo.Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Value = vv
544
+
545
+ End Sub
546
+
547
+ ```
548
+
549
+ 他人が書いたコードは解読するのに苦労するとは思いますが、
550
+
551
+ 参考になれば。
552
+
553
+ ここまで一から書くのに僕の力量で、ヘルプやオブジェクトブラウザで調べながら
554
+
555
+ だいたい4時間くらいかかりました。
556
+
557
+ ぜんぜん解らないところから始めるなら2週間~数か月かかるかも知れません。
558
+
559
+ 解読してみてわからないところがあれば、
560
+
561
+ も少しピンポイントで質問してください。
562
+
563
+ どこから解説していいか解らないし、
564
+
565
+ 全部解説してたら、どんだけ時間が掛かるかわからないし、
566
+
567
+ 入門書1冊書けるくらいかかないといけないようになるので。

2

追記

2020/01/17 13:59

投稿

mattuwan
mattuwan

スコア2136

test CHANGED
@@ -139,3 +139,19 @@
139
139
  が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
140
140
 
141
141
  別途質問してはいかがでしょうか?
142
+
143
+
144
+
145
+ ---
146
+
147
+ > ②について教えて頂きたいのですが様式の表のように「場所+時間」を
148
+
149
+ > ピポッドで表示するにはどうのようにしたらよいのでしょうか?
150
+
151
+
152
+
153
+ 「場所」は列ラベルでは?
154
+
155
+
156
+
157
+ ![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)

1

追記

2020/01/15 03:53

投稿

mattuwan
mattuwan

スコア2136

test CHANGED
@@ -23,3 +23,119 @@
23
23
  3)結果を見せるシートにコピペして好みの形に再編集
24
24
 
25
25
  ぐらいになると思いますがどうでしょうか?
26
+
27
+
28
+
29
+ ---
30
+
31
+
32
+
33
+ > ① 4)にエラーが出ます。
34
+
35
+ > 先月まではエラーはありませんでした。
36
+
37
+ > 何が原因か分かりません。
38
+
39
+ >
40
+
41
+ >
42
+
43
+ > 実行時エラー1004
44
+
45
+ > アプリケーション定義またはオブジェクト定義のエラーです。
46
+
47
+ >
48
+
49
+ > .Add Type:=xlValidateList, _
50
+
51
+ > AlertStyle:=xlValidAlertStop, _
52
+
53
+ > Operator:=xlBetween, _
54
+
55
+ > Formula1:="=名前リスト"
56
+
57
+
58
+
59
+ 名前リストという名前の定義を消したのでは?
60
+
61
+ オブジェクト定義というのは、
62
+
63
+ 今回の場合、指定されたセル範囲(=Rangeオブジェクトと呼ぶ)が存在しない場合によく出ます。
64
+
65
+
66
+
67
+ ②について
68
+
69
+ 上に書きましたが、自作するよりエクセル君が出来ることは、
70
+
71
+ エクセル君に任せた方が処理が速い場合が多いです。
72
+
73
+ 意図が通じて無いようですが、
74
+
75
+ 事前にピボットテーブルを設定したファイルを配布するのですから、
76
+
77
+ ユーザーがピボットテーブルを触ることはありません。
78
+
79
+ マクロで自動でやってもらうよう指示するだけです。
80
+
81
+
82
+
83
+ ③について、
84
+
85
+ >1行空けて
86
+
87
+ with worksheets("?").usedrange
88
+
89
+ .offset(.rows.count+2).cells(1)
90
+
91
+ end with
92
+
93
+
94
+
95
+ ↑が貼付先のセルになると思います。
96
+
97
+
98
+
99
+ >列幅を揃える
100
+
101
+ エクセルにまかせていいなら、
102
+
103
+
104
+
105
+ worksheets("?").usedrange.entirecolumn.autofit
106
+
107
+
108
+
109
+ 各列に既定の幅を設定するなら、
110
+
111
+ 各列毎に設定してください。
112
+
113
+ コードはマクロの記録で探ることが可能だと思います。
114
+
115
+
116
+
117
+ ④について
118
+
119
+ ピボットテーブルというのはまさにこういう表を作るための機能なので、
120
+
121
+ それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
122
+
123
+ 関数でも作成可能です。
124
+
125
+ 表の縦横の項目名を参照して、合計するなら、
126
+
127
+ Sumifs関数が使えます。
128
+
129
+ [SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る
130
+
131
+
132
+
133
+ 当然マクロで一から作ることも可能ですが、
134
+
135
+ 処理速度はデータ数が多くなるほど処理が重くなると思います。
136
+
137
+ が、全然できないよりは出来た方がいいとおもいます。
138
+
139
+ が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
140
+
141
+ 別途質問してはいかがでしょうか?