質問編集履歴

2

追記いたしました。

2021/01/12 06:29

投稿

marino_2021
marino_2021

スコア1

test CHANGED
File without changes
test CHANGED
@@ -438,4 +438,6 @@
438
438
 
439
439
  いろんなところを参考にVBA書いてみたのですがうまくいきません。
440
440
 
441
+ またデータが多くなるとこのコードではすごく重くなります。
442
+
441
443
  ご教授いただきたくよろしくお願いいたします。

1

コードが反映しなかったので追記いたしました。

2021/01/12 06:29

投稿

marino_2021
marino_2021

スコア1

test CHANGED
File without changes
test CHANGED
@@ -64,7 +64,361 @@
64
64
 
65
65
  ```ここに言語名を入力
66
66
 
67
+ Sub リスト取得()
68
+
69
+ Dim i As Long
70
+
71
+ Dim j As Long
72
+
73
+ Dim lastrow As Long
74
+
75
+ lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
76
+
77
+ Worksheets("Sheet2").Cells.Clear
78
+
79
+ Worksheets("Sheet2").Cells(1, 1) = "個人番号"
80
+
81
+ Worksheets("Sheet2").Cells(1, 2) = "会員番号"
82
+
83
+ Worksheets("Sheet2").Cells(1, 3) = "氏名"
84
+
85
+ Worksheets("Sheet2").Cells(1, 4) = "性別"
86
+
87
+ Worksheets("Sheet2").Cells(1, 5) = "年齢"
88
+
89
+ Worksheets("Sheet2").Cells(1, 6) = "生年月日"
90
+
91
+ Worksheets("Sheet2").Cells(1, 7) = "住所"
92
+
93
+ Worksheets("Sheet2").Cells(1, 8) = "会員取得年月日"
94
+
95
+ Worksheets("Sheet2").Cells(1, 9) = "会員喪失年月日"
96
+
97
+ Worksheets("Sheet2").Cells(1, 10) = "身長"
98
+
99
+ Worksheets("Sheet2").Cells(1, 11) = "体重"
100
+
101
+ Worksheets("Sheet2").Cells(1, 12) = "プラン相談"
102
+
103
+ Worksheets("Sheet2").Cells(1, 13) = "食事相談"
104
+
105
+ Worksheets("Sheet2").Cells(1, 14) = "オプション1利用料"
106
+
107
+ Worksheets("Sheet2").Cells(1, 15) = "オプション2利用料"
108
+
109
+
110
+
111
+ For i = 4 To lastrow
112
+
113
+ Worksheets("Sheet2").Cells(i - 2, 1) = Worksheets("Sheet1").Cells(i, 1)
114
+
115
+ Worksheets("Sheet2").Cells(i - 2, 2) = Worksheets("Sheet1").Cells(i, 2)
116
+
117
+ Worksheets("Sheet2").Cells(i - 2, 3) = Worksheets("Sheet1").Cells(i, 3)
118
+
119
+ Worksheets("Sheet2").Cells(i - 2, 4) = Worksheets("Sheet1").Cells(i, 4)
120
+
121
+ Worksheets("Sheet2").Cells(i - 2, 5) = Worksheets("Sheet1").Cells(i, 5)
122
+
123
+ Worksheets("Sheet2").Cells(i - 2, 6) = Worksheets("Sheet1").Cells(i, 6)
124
+
125
+ Worksheets("Sheet2").Cells(i - 2, 7) = Worksheets("Sheet1").Cells(i, 7)
126
+
127
+ Worksheets("Sheet2").Cells(i - 2, 8) = Worksheets("Sheet1").Cells(i, 8)
128
+
129
+ Worksheets("Sheet2").Cells(i - 2, 9) = Worksheets("Sheet1").Cells(i, 9)
130
+
131
+ Worksheets("Sheet2").Cells(i - 2, 10) = Worksheets("Sheet1").Cells(i, 10)
132
+
133
+ Worksheets("Sheet2").Cells(i - 2, 11) = Worksheets("Sheet1").Cells(i, 11)
134
+
135
+ Worksheets("Sheet2").Cells(i - 2, 12) = Worksheets("Sheet1").Cells(i, 12)
136
+
137
+ Worksheets("Sheet2").Cells(i - 2, 13) = Worksheets("Sheet1").Cells(i, 13)
138
+
139
+ Worksheets("Sheet2").Cells(i - 2, 14) = Worksheets("Sheet1").Cells(i, 14)
140
+
141
+ Worksheets("Sheet2").Cells(i - 2, 15) = Worksheets("Sheet1").Cells(i, 15)
142
+
143
+
144
+
145
+ Next
146
+
147
+ Worksheets("Sheet2").Activate
148
+
149
+ Range(Cells(2, 1), Cells(i - 3, 16)).Select
150
+
151
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
152
+
153
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 1), SortOn _
154
+
155
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
156
+
157
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 2), SortOn _
158
+
159
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
160
+
161
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 3), SortOn _
162
+
163
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
164
+
165
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 4), SortOn _
166
+
167
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
168
+
169
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 5), SortOn _
170
+
171
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
172
+
173
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 6), SortOn _
174
+
175
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
176
+
177
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 7), SortOn _
178
+
179
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
180
+
181
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 8), SortOn _
182
+
183
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
184
+
185
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 9), SortOn _
186
+
187
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
188
+
189
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 10), SortOn _
190
+
191
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
192
+
193
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 11), SortOn _
194
+
195
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
196
+
197
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 12), SortOn _
198
+
199
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
200
+
201
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 13), SortOn _
202
+
203
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
204
+
205
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 14), SortOn _
206
+
207
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
208
+
209
+ ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Cells(2, 15), SortOn _
210
+
211
+ :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
212
+
213
+
214
+
215
+ With ActiveWorkbook.Worksheets("Sheet2").Sort
216
+
217
+ '並べ替える範囲を指定
218
+
219
+ .SetRange Range(Cells(2, 1), Cells(i - 3, 16))
220
+
221
+ '1行目がタイトル行かどうか
222
+
223
+ .Header = xlNo
224
+
225
+ '大文字と小文字を区別するかどうか
226
+
227
+ .MatchCase = False
228
+
229
+ '並べ替えの方向(行/列)を指定
230
+
231
+ .Orientation = xlTopToBottom
232
+
233
+ 'ふりがなを使うかどうか
234
+
235
+ .SortMethod = xlPinYin
236
+
237
+ '並べ替えを実行
238
+
67
- ソースコード
239
+ .Apply
240
+
241
+ End With
242
+
243
+ Call 最新の取り出し
244
+
245
+
246
+
247
+ End Sub
248
+
249
+
250
+
251
+ Sub 最新の取り出し()
252
+
253
+ Dim i As Long
254
+
255
+ Dim j As Long
256
+
257
+ Dim lastrow As Long
258
+
259
+ Dim kei As Long
260
+
261
+ Dim kei1 As Double
262
+
263
+ Dim kei2 As Double
264
+
265
+ Dim maru1 As String
266
+
267
+ Dim maru2 As String
268
+
269
+
270
+
271
+ lastrow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
272
+
273
+ For i = 2 To lastrow
274
+
275
+ Worksheets("Sheet2").Cells(i, 16) = 1
276
+
277
+ Next
278
+
279
+ Worksheets("Sheet3").Cells(1, 1) = "個人番号"
280
+
281
+ Worksheets("Sheet3").Cells(1, 2) = "会員番号"
282
+
283
+ Worksheets("Sheet3").Cells(1, 3) = "氏名"
284
+
285
+ Worksheets("Sheet3").Cells(1, 4) = "性別"
286
+
287
+ Worksheets("Sheet3").Cells(1, 5) = "年齢"
288
+
289
+ Worksheets("Sheet3").Cells(1, 6) = "生年月日"
290
+
291
+ Worksheets("Sheet3").Cells(1, 7) = "住所"
292
+
293
+ Worksheets("Sheet3").Cells(1, 8) = "会員取得年月日"
294
+
295
+ Worksheets("Sheet3").Cells(1, 9) = "会員喪失年月日"
296
+
297
+ Worksheets("Sheet3").Cells(1, 10) = "身長"
298
+
299
+ Worksheets("Sheet3").Cells(1, 11) = "体重"
300
+
301
+ Worksheets("Sheet3").Cells(1, 12) = "プラン相談"
302
+
303
+ Worksheets("Sheet3").Cells(1, 13) = "食事相談"
304
+
305
+ Worksheets("Sheet3").Cells(1, 14) = "オプション1利用料"
306
+
307
+ Worksheets("Sheet3").Cells(1, 15) = "オプション2利用料"
308
+
309
+
310
+
311
+ Worksheets("Sheet3").Cells(1, 16) = "件数"
312
+
313
+
314
+
315
+ j = 2
316
+
317
+ kei = 0
318
+
319
+ maru1 = ""
320
+
321
+ maru2 = ""
322
+
323
+ kei1 = 0
324
+
325
+ kei2 = 0
326
+
327
+
328
+
329
+
330
+
331
+ For i = 2 To lastrow
332
+
333
+ kei = kei + Worksheets("Sheet2").Cells(i, 16)
334
+
335
+ kei1 = kei1 + Worksheets("Sheet2").Cells(i, 14)
336
+
337
+ kei2 = kei2 + Worksheets("Sheet2").Cells(i, 15)
338
+
339
+
340
+
341
+ If Worksheets("Sheet2").Cells(i, 12) = "○" Then
342
+
343
+ maru1 = "○"
344
+
345
+ End If
346
+
347
+ If Worksheets("Sheet2").Cells(i, 13) = "○" Then
348
+
349
+ maru2 = "○"
350
+
351
+ End If
352
+
353
+
354
+
355
+
356
+
357
+ If Worksheets("Sheet2").Cells(i, 1) <> Worksheets("Sheet2").Cells(i + 1, 1) Then
358
+
359
+ Worksheets("Sheet3").Cells(j, 1) = Worksheets("Sheet2").Cells(i, 1)
360
+
361
+ Worksheets("Sheet3").Cells(j, 2) = Worksheets("Sheet2").Cells(i, 2)
362
+
363
+ Worksheets("Sheet3").Cells(j, 3) = Worksheets("Sheet2").Cells(i, 3)
364
+
365
+ Worksheets("Sheet3").Cells(j, 4) = Worksheets("Sheet2").Cells(i, 4)
366
+
367
+ Worksheets("Sheet3").Cells(j, 5) = Worksheets("Sheet2").Cells(i, 5)
368
+
369
+ Worksheets("Sheet3").Cells(j, 6) = Worksheets("Sheet2").Cells(i, 6)
370
+
371
+ Worksheets("Sheet3").Cells(j, 7) = Worksheets("Sheet2").Cells(i, 7)
372
+
373
+ Worksheets("Sheet3").Cells(j, 8) = Worksheets("Sheet2").Cells(i, 8)
374
+
375
+ Worksheets("Sheet3").Cells(j, 9) = Worksheets("Sheet2").Cells(i, 9)
376
+
377
+ Worksheets("Sheet3").Cells(j, 10) = Worksheets("Sheet2").Cells(i, 10)
378
+
379
+ Worksheets("Sheet3").Cells(j, 11) = Worksheets("Sheet2").Cells(i, 11)
380
+
381
+ Worksheets("Sheet3").Cells(j, 12) = maru1
382
+
383
+ Worksheets("Sheet3").Cells(j, 13) = maru2
384
+
385
+ Worksheets("Sheet3").Cells(j, 14) = kei1
386
+
387
+ Worksheets("Sheet3").Cells(j, 15) = kei2
388
+
389
+
390
+
391
+ Worksheets("Sheet3").Cells(j, 16) = kei
392
+
393
+ j = j + 1
394
+
395
+ kei = 0
396
+
397
+ kei1 = 0
398
+
399
+ kei2 = 0
400
+
401
+ maru1 = ""
402
+
403
+ maru2 = ""
404
+
405
+
406
+
407
+ End If
408
+
409
+ Next
410
+
411
+
412
+
413
+
414
+
415
+ Worksheets("Sheet3").Select
416
+
417
+
418
+
419
+ End Sub
420
+
421
+
68
422
 
69
423
  ```
70
424
 
@@ -82,4 +436,6 @@
82
436
 
83
437
 
84
438
 
439
+ いろんなところを参考にVBA書いてみたのですがうまくいきません。
440
+
85
- ここにり詳細な情報を記載ださい。
441
+ ご教授いただきたくしくお願いたします