質問編集履歴

1

載せていたコードの範囲を広げました

2021/04/21 04:33

投稿

kktok
kktok

スコア23

test CHANGED
File without changes
test CHANGED
@@ -40,6 +40,508 @@
40
40
 
41
41
  ```VBA
42
42
 
43
+ 'inTSはobjFSO.OpenTextFileで読み込んだ対象データ、targetColNameは判定列の名前、targetKeyArr()は集計対象外となる条件群、targetFolderPath はCSVのパス
44
+
45
+ Sub trimCsvOrg2(ByRef inTS As Variant, ByVal targetColName As String, ByRef targetKeyArr() As String, targetFolderPath As String)
46
+
47
+
48
+
49
+ Dim currentRow As Long, currentColumn As Long, indexChara As Long
50
+
51
+ Dim lngQuote As Long
52
+
53
+ Dim strTarget As String
54
+
55
+ Dim targetColumn As Long
56
+
57
+ Dim isAdd As Boolean: isAdd = True
58
+
59
+ Dim strArr() As String
60
+
61
+ Dim strRec As String
62
+
63
+ Dim test1 As Long
64
+
65
+ Dim resultCSV As Workbook
66
+
67
+ Dim strResults() As String
68
+
69
+ Dim dimenNum As Long
70
+
71
+ Dim startR As Long: startR = 1
72
+
73
+ Dim countThrough As Long: countThrough = 0
74
+
75
+ Dim countColumn As Long: countColumn = 100000
76
+
77
+
78
+
79
+ Set resultCSV = returnWB(targetFolderPath)
80
+
81
+
82
+
83
+ currentRow = 1 'シートの1行目から出力
84
+
85
+ currentColumn = 0 '列位置はupdateConditionsでカウントアップ
86
+
87
+ lngQuote = 0 'ダブルクォーテーションの数
88
+
89
+ targetColumn = 0 '列番号の初期化
90
+
91
+ strTarget = ""
92
+
93
+
94
+
95
+ Do While Not inTS.AtEndOfStream
96
+
97
+
98
+
99
+ On Error GoTo err2
100
+
101
+
102
+
103
+ strRec = CStr(inTS.Read(1))
104
+
105
+
106
+
107
+ Select Case strRec
108
+
109
+
110
+
111
+ Case vbLf, vbCr '「"」が偶数なら改行、奇数ならただの文字
112
+
113
+
114
+
115
+ If lngQuote Mod 2 = 0 Then
116
+
117
+
118
+
119
+ strRec = strRec & CStr(inTS.Read(1)) '改行としてのCrが出てきたらLfも読み込んで捨てる
120
+
121
+
122
+
123
+ '行が変わる時の処理。追加判定が真なら1次元配列を2次元配列に突っ込む
124
+
125
+ If isAdd Then
126
+
127
+ Call pushValueToArr(strTarget, strArr) '成型した文字列を配列に格納
128
+
129
+ Call pushArrToMDArr(strResults, strArr, dimenNum, countColumn) '2次元配列に1次元配列を突っ込む
130
+
131
+ If currentRow = 1 Then countColumn = UBound(strArr)
132
+
133
+
134
+
135
+ '5000次元までいった時点でシートに差し込む
136
+
137
+ If dimenNum = 4999 Then
138
+
139
+
140
+
141
+ startR = pushArrToCells(resultCSV.Worksheets(1), startR, dimenNum, strResults)
142
+
143
+ dimenNum = 0
144
+
145
+
146
+
147
+ End If
148
+
149
+
150
+
151
+ Else
152
+
153
+
154
+
155
+ countThrough = countThrough + 1
156
+
157
+
158
+
159
+ End If
160
+
161
+
162
+
163
+ Erase strArr '1次元配列をリセットする
164
+
165
+
166
+
167
+ Call updateConditions(currentColumn, strTarget, lngQuote) '列が変わる時の処理
168
+
169
+ currentRow = currentRow + 1
170
+
171
+ isAdd = True
172
+
173
+ currentColumn = 0
174
+
175
+ lngQuote = 0
176
+
177
+
178
+
179
+ Else
180
+
181
+
182
+
183
+ strTarget = strTarget & strRec
184
+
185
+
186
+
187
+ End If
188
+
189
+
190
+
191
+ Case "," '「"」が偶数なら区切り、奇数ならただの文字
192
+
193
+
194
+
195
+ If lngQuote Mod 2 = 0 Then
196
+
197
+
198
+
199
+ If targetColumn = 0 Then Call getTargetColumnIndex(currentColumn, targetColumn, strTarget, targetColName) '項目行なら判定行のインデックスを探す
200
+
201
+ If currentRow > 1 And (currentColumn + 1) = targetColumn Then isAdd = Not isMemberInArr(targetKeyArr, strTarget)
202
+
203
+ If isAdd Then Call pushValueToArr(strTarget, strArr()) '成型した文字列を配列に格納
204
+
205
+ Call updateConditions(currentColumn, strTarget, lngQuote) '列が変わる時の処理
206
+
207
+
208
+
209
+ Else
210
+
211
+
212
+
213
+ strTarget = strTarget & strRec
214
+
215
+
216
+
217
+ End If
218
+
219
+
220
+
221
+ Case """" '「"」のカウントをとる
222
+
223
+
224
+
225
+ lngQuote = lngQuote + 1
226
+
227
+ strTarget = strTarget & strRec
228
+
229
+
230
+
231
+ Case Else
232
+
233
+
234
+
235
+ strTarget = strTarget & strRec
236
+
237
+
238
+
239
+ End Select
240
+
241
+
242
+
243
+ Loop
244
+
245
+
246
+
247
+ '最終セルの処理
248
+
249
+ If currentColumn > 0 And strTarget <> "" Then
250
+
251
+
252
+
253
+ If (currentColumn + 1) = targetColumn Then isAdd = isMemberInArr(targetKeyArr, strTarget)
254
+
255
+ If isAdd Then Call pushValueToArr(strTarget, strArr) '成型した文字列を配列に格納
256
+
257
+ Call updateConditions(currentColumn, strTarget, lngQuote) '列が変わる時の処理
258
+
259
+
260
+
261
+ End If
262
+
263
+
264
+
265
+ If Not Not strResults Then
266
+
267
+
268
+
269
+ Call pushArrToCells(resultCSV.Worksheets(1), startR, dimenNum, strResults)
270
+
271
+
272
+
273
+ End If
274
+
275
+
276
+
277
+ resultCSV.Save
278
+
279
+
280
+
281
+ err2:
282
+
283
+ MsgBox (err.Description)
284
+
285
+
286
+
287
+
288
+
289
+ End Sub
290
+
291
+
292
+
293
+ '対象列の値なら配列に追加する
294
+
295
+ '①現在の列インデックス②対象の文字列③ダブルクォーテーションの数④対象列名⑤対象列インデックス⑥文字列配列
296
+
297
+ Sub updateConditions(ByRef currentColumn As Long, ByRef strTarget As String, ByRef lngQuote As Long)
298
+
299
+
300
+
301
+ currentColumn = currentColumn + 1
302
+
303
+ lngQuote = 0
304
+
305
+
306
+
307
+ strTarget = ""
308
+
309
+
310
+
311
+ End Sub
312
+
313
+ '項目列が判定列ならインデックスを返す
314
+
315
+ Sub getTargetColumnIndex(ByVal currentColumn As Long, ByRef targetColumn As Long, ByVal strTarget As String, ByVal targetColName As String)
316
+
317
+
318
+
319
+ If editStrIsBlank(strTarget) = targetColName Then
320
+
321
+
322
+
323
+ targetColumn = currentColumn + 1
324
+
325
+
326
+
327
+ End If
328
+
329
+
330
+
331
+ End Sub
332
+
333
+
334
+
335
+ '空白なら""を、それ以外なら"を取った値に編集する
336
+
337
+ Function editStrIsBlank(ByVal strTarget As String)
338
+
339
+
340
+
341
+ If Left(strTarget, 1) = """" And Right(strTarget, 1) = """" Then
342
+
343
+
344
+
345
+ If Len(strTarget) <= 2 Then
346
+
347
+
348
+
349
+ editStrIsBlank = ""
350
+
351
+ Exit Function
352
+
353
+
354
+
355
+ Else
356
+
357
+
358
+
359
+ editStrIsBlank = Mid(strTarget, 2, Len(strTarget) - 2)
360
+
361
+ Exit Function
362
+
363
+
364
+
365
+ End If
366
+
367
+
368
+
369
+ End If
370
+
371
+
372
+
373
+ editStrIsBlank = strTarget
374
+
375
+
376
+
377
+ End Function
378
+
379
+
380
+
381
+ '文字列の"を削除、最大数を増やして1次元配列に値を入れる
382
+
383
+ Sub pushValueToArr(ByVal strTarget As String, ByRef strArr() As String)
384
+
385
+
386
+
387
+ strTarget = Replace(strTarget, """""", """") '前後の「"」を削除
388
+
389
+
390
+
391
+ strTarget = editStrIsBlank(strTarget) '空白なら""を、それ以外なら"を取った値に編集する
392
+
393
+
394
+
395
+ If Not Not strArr Then '配列が初期化済みなら上限数を増やして追加する
396
+
397
+
398
+
399
+ ReDim Preserve strArr(UBound(strArr) + 1)
400
+
401
+
402
+
403
+ Else
404
+
405
+
406
+
407
+ ReDim strArr(0)
408
+
409
+
410
+
411
+ End If
412
+
413
+
414
+
415
+ strArr(UBound(strArr)) = strTarget
416
+
417
+
418
+
419
+ End Sub
420
+
421
+
422
+
423
+ '1次元配列の値をすべて2次元配列に入れる(呼び出し元は最後にtransposeする)。1列目以降は次元数の横方向固定
424
+
425
+ Sub pushArrToMDArr(strResults() As String, strArr() As String, ByRef dimenNum As Long, ByVal countColumn As Long)
426
+
427
+
428
+
429
+ Dim temp As Variant
430
+
431
+ Dim errA As Variant
432
+
433
+
434
+
435
+ If countColumn = 100000 Then
436
+
437
+
438
+
439
+ countColumn = UBound(strArr)
440
+
441
+
442
+
443
+ End If
444
+
445
+
446
+
447
+ If Not Not strResults Then '配列が初期化済みなら上限数を増やして追加する
448
+
449
+
450
+
451
+ dimenNum = dimenNum + 1
452
+
453
+
454
+
455
+ End If
456
+
457
+
458
+
459
+ ReDim Preserve strResults(countColumn, dimenNum)
460
+
461
+
462
+
463
+
464
+
465
+ For i = 0 To countColumn
466
+
467
+
468
+
469
+ If i > UBound(strArr) Then
470
+
471
+
472
+
473
+ strResults(i, dimenNum) = ""
474
+
475
+
476
+
477
+ Else
478
+
479
+
480
+
481
+ strResults(i, dimenNum) = strArr(i)
482
+
483
+
484
+
485
+ End If
486
+
487
+
488
+
489
+ Next i
490
+
491
+
492
+
493
+ End Sub
494
+
495
+
496
+
497
+ '指定要素が配列のメンバーかどうか返す
498
+
499
+ Function isMemberInArr(targetKeyArr() As String, strTarget As String) As Boolean
500
+
501
+
502
+
503
+ Dim result As Variant
504
+
505
+
506
+
507
+ result = Filter(targetKeyArr(), strTarget)
508
+
509
+
510
+
511
+ isMemberInArr = (UBound(result) <> -1)
512
+
513
+
514
+
515
+ End Function
516
+
517
+
518
+
519
+ 'ワークブックを作る
520
+
521
+ Function returnWB(path As String) As Workbook
522
+
523
+
524
+
525
+ Dim wbResult As Workbook
526
+
527
+ Set wbResult = Workbooks.Add
528
+
529
+ wbResult.SaveAs fileName:=path & "編集済データ.csv", _
530
+
531
+ FileFormat:=xlCSV
532
+
533
+
534
+
535
+ Set returnWB = wbResult
536
+
537
+
538
+
539
+ End Function
540
+
541
+
542
+
543
+ '2次元配列をシート内に突っ込む
544
+
43
545
  Function pushArrToCells(ByRef ws As Worksheet, ByVal startR As Long, ByVal dimenNum As Long, ByRef strResults() As String) As Long
44
546
 
45
547
 
@@ -56,7 +558,7 @@
56
558
 
57
559
 
58
560
 
59
- Erase strResults '配列の上限数を超えてしまうのを防ぐため張り付けたあとに一度リセットする
561
+ Erase strResults
60
562
 
61
563
 
62
564
 
@@ -66,4 +568,6 @@
66
568
 
67
569
  End Function
68
570
 
571
+
572
+
69
573
  ```