teratail
回答率
85.47%
質問するログイン新規登録
トップVBAに関する質問2つのテーブルを一つにまとめる方法

編集履歴

回答編集履歴

3

使わないかもだけど4/2追加分一部修正しました

2020/04/03 10:39

投稿

end-u
end-u

スコア52

test CHANGED
@@ -402,6 +402,8 @@
402
402
 
403
403
  ws.Activate
404
404
 
405
+ Set rr = d.Areas(1).Offset(, -1)
406
+
405
407
  For Each r1 In d.Areas
406
408
 
407
409
  r1.Value = r1.Value
@@ -414,7 +416,7 @@
414
416
 
415
417
  If IsNumeric(y) Then
416
418
 
417
- r1(y).Value = r1(y).Value & "｜" & r2.Offset(, 1).Value
419
+ r1(y).Value = CStr(r1(y).Value) & "｜" & r2.Offset(, 1).Value
418
420
 
419
421
  End If
420
422
 

2

サンプル追加

2020/04/03 10:39

投稿

end-u
end-u

スコア52

test CHANGED
@@ -191,3 +191,249 @@
191
191
  End Sub
192
192
 
193
193
  ```
194
+
195
+ （2020.04.02追加）
196
+
197
+ ..なんか自分でも納得いかないコードですが..
198
+
199
+ すみません、「こんなアプローチもあります」的なサンプル扱いでお願いします
200
+
201
+
202
+
203
+ ```VBA
204
+
205
+ Sub test2()
206
+
207
+ Dim r As Range
208
+
209
+ Dim d As Range
210
+
211
+ Dim dd As Range
212
+
213
+ Dim cc As Range
214
+
215
+ Dim rr As Range
216
+
217
+ Dim x As Long
218
+
219
+ Dim i As Long
220
+
221
+ Dim j As Long
222
+
223
+ Dim k As Long
224
+
225
+
226
+
227
+ '予定表の範囲を取得
228
+
229
+ With Sheets("予定表")
230
+
231
+ Set r = .Range("A2").CurrentRegion
232
+
233
+ Set dd = .Range("B3", r(r.Count))
234
+
235
+ End With
236
+
237
+ Set cc = dd.Resize(1).Offset(-1)
238
+
239
+ Set rr = dd.Resize(, 1).Offset(, -1)
240
+
241
+
242
+
243
+ Dim pt As PivotTable
244
+
245
+ Dim st As String
246
+
247
+ Dim ws As Worksheet
248
+
249
+ Set ws = Sheets.Add
250
+
251
+
252
+
253
+ With Sheets("日報")
254
+
255
+ x = .Cells(.Rows.Count, 10).End(xlUp).Row
256
+
257
+ k = x + 1 '最後のデータクリアで使う
258
+
259
+
260
+
261
+ '日報から氏名、日付、略号場所キーでピボット作成 _
262
+
263
+ 後で日報ベースの予定｜実績の実績データ追加で使う
264
+
265
+ Set r = .Range("A1", .Cells(x, "L"))
266
+
267
+ r.Columns("L").Formula = "=B1&H1"
268
+
269
+ st = .Range("L1").Value
270
+
271
+ Set pt = ActiveWorkbook.PivotCaches.Add( _
272
+
273
+ SourceType:=xlDatabase, _
274
+
275
+ SourceData:=r) _
276
+
277
+ .CreatePivotTable(ws.Range("A1"))
278
+
279
+ pt.ColumnGrand = False
280
+
281
+ pt.RowGrand = False
282
+
283
+ pt.RowAxisLayout xlTabularRow
284
+
285
+ With pt.PivotFields("氏名")
286
+
287
+ .Orientation = xlRowField
288
+
289
+ .Subtotals(1) = False
290
+
291
+ End With
292
+
293
+ With pt.PivotFields("日付")
294
+
295
+ .Orientation = xlRowField
296
+
297
+ .Subtotals(1) = False
298
+
299
+ End With
300
+
301
+ pt.PivotFields(st).Orientation = xlRowField
302
+
303
+ pt.AddDataField pt.PivotFields("執務時間"), "執務時間計", xlSum
304
+
305
+ '予定表の氏名と日付を日報に追加
306
+
307
+ x = x + 1
308
+
309
+ For i = 1 To rr.Count
310
+
311
+ For j = 1 To cc.Count
312
+
313
+ If dd(i, j).Value <> "" Then
314
+
315
+ .Cells(x, "D").Value = rr(i).Value
316
+
317
+ .Cells(x, "J").Value = cc(j).Value
318
+
319
+ x = x + 1
320
+
321
+ End If
322
+
323
+ Next
324
+
325
+ Next
326
+
327
+ Set r = .Range("A1", .Cells(x - 1, "L"))
328
+
329
+ End With
330
+
331
+ 'ピボット利用して「結合」シート作成
332
+
333
+ Dim ws2 As Worksheet
334
+
335
+ Set ws2 = Sheets.Add
336
+
337
+ With ActiveWorkbook.PivotCaches.Add( _
338
+
339
+ SourceType:=xlDatabase, _
340
+
341
+ SourceData:=r) _
342
+
343
+ .CreatePivotTable(ws2.Range("A1"))
344
+
345
+ .ColumnGrand = False
346
+
347
+ .RowGrand = False
348
+
349
+ .RowAxisLayout xlTabularRow
350
+
351
+ .PivotFields("日付").Orientation = xlRowField
352
+
353
+ .PivotFields("氏名").Orientation = xlColumnField
354
+
355
+ .AddDataField .PivotFields("略号"), "予定｜実績", xlCount
356
+
357
+ .AddDataField .PivotFields("執務時間"), "執務時間計", xlSum
358
+
359
+ .DataPivotField.Orientation = xlColumnField
360
+
361
+ '"予定｜実績"の範囲取得
362
+
363
+ .PivotSelect "予定｜実績", xlDataOnly
364
+
365
+ Set d = Selection
366
+
367
+ 'PivotTableを解除
368
+
369
+ .TableRange2.Copy
370
+
371
+ .TableRange2.PasteSpecial xlPasteValues
372
+
373
+ End With
374
+
375
+ Application.CutCopyMode = False
376
+
377
+
378
+
379
+ '予定表から予定｜実績データ追加 _
380
+
381
+ 数式文字列設定 =INDEX(dd,MATCH($A4,rr,0),MATCH(B$2,cc,0))&""
382
+
383
+ Dim s(2) As String
384
+
385
+ s(0) = "=index(" & dd.Address(, , , True)
386
+
387
+ s(1) = "match($A4," & rr.Address(, , , True) & ",0)"
388
+
389
+ s(2) = "match(B$2," & cc.Address(, , , True) & ",0))&"""""
390
+
391
+ d.Formula = Join(s, ",")
392
+
393
+
394
+
395
+ '日報ベースの予定｜実績の実績データ追加
396
+
397
+ Dim r1 As Range
398
+
399
+ Dim r2 As Range
400
+
401
+ Dim y
402
+
403
+ ws.Activate
404
+
405
+ For Each r1 In d.Areas
406
+
407
+ r1.Value = r1.Value
408
+
409
+ pt.PivotSelect r1(1).Offset(-2).Value, xlLabelOnly
410
+
411
+ For Each r2 In Selection.Offset(, 1)
412
+
413
+ y = Application.Match(CLng(r2.Value), rr, 0)
414
+
415
+ If IsNumeric(y) Then
416
+
417
+ r1(y).Value = r1(y).Value & "｜" & r2.Offset(, 1).Value
418
+
419
+ End If
420
+
421
+ Next
422
+
423
+ Next
424
+
425
+ '追加したダミーデータと作業用Sheetをクリア
426
+
427
+ r.Columns("L").ClearContents
428
+
429
+ Range(r(k, 1), r(r.Count)).ClearContents
430
+
431
+ Application.DisplayAlerts = False
432
+
433
+ ws.Delete
434
+
435
+ Application.DisplayAlerts = True
436
+
437
+ End Sub
438
+
439
+ ```

1

別案

2020/04/02 14:13

投稿

end-u
end-u

スコア52

test CHANGED
@@ -73,3 +73,121 @@
73
73
  修正後の式を下方向と各氏名の後に挿入した列にコピーすると良いです
74
74
 
75
75
  必要に応じて要所要所をマクロ化すれば良いでしょう
76
+
77
+
78
+
79
+ （追記）
80
+
81
+ ぁ一応、逆に日報ベースの別案も作ってはいましたけどね
82
+
83
+ ピボットをベースに予定表の内容がMatchするものをひっぱってくる感じ。
84
+
85
+ 提示のレイアウト限定ではありますが
86
+
87
+ ```VBA
88
+
89
+ Sub test()
90
+
91
+ Dim r As Range
92
+
93
+ Dim d As Range
94
+
95
+ Dim dd As Range
96
+
97
+ Dim cc As Range
98
+
99
+ Dim rr As Range
100
+
101
+
102
+
103
+ With Sheets("日報")
104
+
105
+ 'PivotTableのSourceData
106
+
107
+ Set r = .Range("K1", .Cells(.Rows.Count, 4).End(xlUp).Offset(, -3))
108
+
109
+ End With
110
+
111
+
112
+
113
+ 'とりあえず新規Sheetに集計してみる
114
+
115
+ With ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
116
+
117
+ SourceData:=r).CreatePivotTable("")
118
+
119
+ .PivotFields("日付").Orientation = xlRowField
120
+
121
+ .PivotFields("氏名").Orientation = xlColumnField
122
+
123
+ '"略号"の集計はダミー。後で数式セット
124
+
125
+ .AddDataField .PivotFields("略号"), "略号&場所", xlCount
126
+
127
+ .AddDataField .PivotFields("執務時間"), "執務時間計", xlSum
128
+
129
+ .DataPivotField.Orientation = xlColumnField
130
+
131
+ .ColumnGrand = False
132
+
133
+ .RowGrand = False
134
+
135
+ .RowAxisLayout xlTabularRow
136
+
137
+ '"略号&場所"の範囲取得
138
+
139
+ .PivotSelect "'略号&場所'", xlDataOnly
140
+
141
+ Set d = Selection
142
+
143
+ .TableRange2.Copy
144
+
145
+ 'PivotTableを解除
146
+
147
+ .TableRange2.PasteSpecial xlPasteValues
148
+
149
+ End With
150
+
151
+ Application.CutCopyMode = False
152
+
153
+
154
+
155
+ '数式の参照先アドレスget
156
+
157
+ With Sheets("予定表")
158
+
159
+ Set r = .Range("A2").CurrentRegion
160
+
161
+ Set dd = .Range("B3", r(r.Count))
162
+
163
+ End With
164
+
165
+ Set cc = dd.Resize(1).Offset(-1)
166
+
167
+ Set rr = dd.Resize(, 1).Offset(, -1)
168
+
169
+
170
+
171
+ '数式文字列設定 =INDEX(dd,MATCH($A4,rr,0),MATCH(B$2,cc,0))&""
172
+
173
+ Dim s(2) As String
174
+
175
+ s(0) = "=index(" & dd.Address(, , , True)
176
+
177
+ s(1) = "match($A4," & rr.Address(, , , True) & ",0)"
178
+
179
+ s(2) = "match(B$2," & cc.Address(, , , True) & ",0))&"""""
180
+
181
+ d.Formula = Join(s, ",")
182
+
183
+ '数式の値化が必要であれば以下コメント活かす
184
+
185
+ 'For Each r In d.Areas
186
+
187
+ ' r.Value = r.Value
188
+
189
+ 'Next
190
+
191
+ End Sub
192
+
193
+ ```