質問編集履歴

1

解決

2020/03/30 14:21

投稿

Izumo1101
Izumo1101

スコア49

test CHANGED
File without changes
test CHANGED
@@ -161,3 +161,117 @@
161
161
  End Sub
162
162
 
163
163
  ```
164
+
165
+
166
+
167
+ ピポットテーブルは手付かずで、ご助言いただいたことを参考に勉強します。とりあえず回答順に参考にさせていただきました。記述も少なくて済み、処理時間もそれほど長くなかったのでシンプルに考えられました。
168
+
169
+ 効率的といえばピポットテーブルだということも理解できました。
170
+
171
+
172
+
173
+ ```vba
174
+
175
+ Sub 集計テスト()
176
+
177
+ Dim i As Long, n As Long, m As Long, l As Long
178
+
179
+ Dim x As String, y As String, z As String
180
+
181
+ Dim cnt(1 To 20) As Long
182
+
183
+ Dim buf As Variant
184
+
185
+ Dim ws As Worksheet
186
+
187
+ Dim rng As Range
188
+
189
+
190
+
191
+ Application.ScreenUpdating = False
192
+
193
+ For i = 8 To 19
194
+
195
+ Sheets(i).Range("f9:m101").ClearContents
196
+
197
+ Next i
198
+
199
+
200
+
201
+ Set ws = Sheets("利用記録")
202
+
203
+ i = ws.Cells(1, 1).End(xlDown).Row
204
+
205
+ buf = ws.Cells(2, 1).Resize(i, 12).Value
206
+
207
+
208
+
209
+ For i = 1 To UBound(buf)
210
+
211
+ Sheets(Month(buf(i, 10)) & "月").Select
212
+
213
+ n = Day(buf(i, 10))
214
+
215
+ Set rng = Range("b8:b101").Find(what:=n, lookat:=xlWhole).Offset(0, 3)
216
+
217
+
218
+
219
+
220
+
221
+ If buf(i, 5) = "幼児・小学生" Then
222
+
223
+ m = rng.Offset(0, 1).Row
224
+
225
+ ElseIf buf(i, 5) = "中・高校生" Then
226
+
227
+ m = rng.Offset(1, 1).Row
228
+
229
+ ElseIf buf(i, 5) = "一般" Then
230
+
231
+ m = rng.Offset(2, 1).Row
232
+
233
+ End If
234
+
235
+
236
+
237
+ If Format(buf(i, 6), "Short Time") > "09:00" And Format(buf(i, 6), "Short Time") <= "12:00" Then
238
+
239
+ l = 6
240
+
241
+ ElseIf Format(buf(i, 6), "Short Time") > "12:00" And Format(buf(i, 6), "Short Time") <= "17:00" Then
242
+
243
+ l = 8
244
+
245
+ ElseIf Format(buf(i, 6), "Short Time") > "17:00" And Format(buf(i, 6), "Short Time") <= "19:00" Then
246
+
247
+ l = 10
248
+
249
+ ElseIf Format(buf(i, 6), "Short Time") > "19:00" And Format(buf(i, 6), "Short Time") <= "21:00" Then
250
+
251
+ l = 12
252
+
253
+ End If
254
+
255
+
256
+
257
+ If buf(i, 8) = "バット" Then
258
+
259
+ l = l + 1
260
+
261
+ End If
262
+
263
+
264
+
265
+ Cells(m, l).Value = Cells(m, l).Value + buf(i, 7) '利用人数の項目があったためこれを追記
266
+
267
+ Next i
268
+
269
+
270
+
271
+ Application.ScreenUpdating = True
272
+
273
+ End Sub
274
+
275
+ ```
276
+
277
+ 皆さんありがとうございました。