980MBのCSVについて条件に沿ったデータのみ抽出する際、一定行以降で貼り付け時にエラーが発生する

経緯

列数が236行、行数がExcelで開く限りでは表示できない量の巨大なCSVについて、
条件に沿ったデータ行のみを抽出するファンクションを作成しています。

①列によっては改行文字が含まれるためFileSystemObjectのReadメソッドを用いて一文字ずつ読み込んでいく
②1行分の処理が終わった時点で1次元配列に格納していた行について条件に合致した場合のみ多次元配列に格納する
③多次元配列に格納した回数が5000回に達した時点で一度CSVに貼り付ける

という処理をDoループで繰り返すことで実現しようとしていました。

問題

30000行を超えた時点でそれまで出てこなかった

アプリケーション定義またはオブジェクト定義のエラーです

といった内容のエラーが発生し貼り付けが不可能となってしまいました。

30000行前後であれば行数的にはExcelで開く分にも問題ない程度のデータ量であることから
原因が分からず、お教えいただけますと幸いです。

VBA
1'inTSはobjFSO.OpenTextFileで読み込んだ対象データ、targetColNameは判定列の名前、targetKeyArr()は集計対象外となる条件群、targetFolderPath はCSVのパス
2Sub trimCsvOrg2(ByRef inTS As Variant, ByVal targetColName As String, ByRef targetKeyArr() As String, targetFolderPath As String)
3
4    Dim currentRow As Long, currentColumn As Long, indexChara As Long
5    Dim lngQuote As Long
6    Dim strTarget As String
7    Dim targetColumn As Long
8    Dim isAdd As Boolean: isAdd = True
9    Dim strArr() As String
10    Dim strRec As String
11    Dim test1 As Long
12    Dim resultCSV As Workbook
13    Dim strResults() As String
14    Dim dimenNum As Long
15    Dim startR As Long: startR = 1
16    Dim countThrough As Long: countThrough = 0
17    Dim countColumn As Long: countColumn = 100000
18    
19    Set resultCSV = returnWB(targetFolderPath)
20
21    currentRow = 1 'シートの1行目から出力
22    currentColumn = 0 '列位置はupdateConditionsでカウントアップ
23    lngQuote = 0 'ダブルクォーテーションの数
24    targetColumn = 0 '列番号の初期化
25    strTarget = ""
26    
27    Do While Not inTS.AtEndOfStream
28    
29        On Error GoTo err2
30        
31        strRec = CStr(inTS.Read(1))
32        
33        Select Case strRec
34        
35            Case vbLf, vbCr '「"」が偶数なら改行、奇数ならただの文字
36            
37                If lngQuote Mod 2 = 0 Then
38                        
39                    strRec = strRec & CStr(inTS.Read(1)) '改行としてのCrが出てきたらLfも読み込んで捨てる
40                    
41                    '行が変わる時の処理。追加判定が真なら1次元配列を2次元配列に突っ込む
42                    If isAdd Then
43                        Call pushValueToArr(strTarget, strArr) '成型した文字列を配列に格納
44                        Call pushArrToMDArr(strResults, strArr, dimenNum, countColumn)  '2次元配列に1次元配列を突っ込む
45                        If currentRow = 1 Then countColumn = UBound(strArr)
46                        
47                        '5000次元までいった時点でシートに差し込む
48                        If dimenNum = 4999 Then
49                            
50                            startR = pushArrToCells(resultCSV.Worksheets(1), startR, dimenNum, strResults)
51                            dimenNum = 0
52                            
53                        End If
54                      
55                    Else
56                    
57                        countThrough = countThrough + 1
58                      
59                    End If
60                        
61                    Erase strArr '1次元配列をリセットする
62                        
63                    Call updateConditions(currentColumn, strTarget, lngQuote)  '列が変わる時の処理
64                    currentRow = currentRow + 1
65                    isAdd = True
66                    currentColumn = 0
67                    lngQuote = 0
68                    
69                Else
70                
71                    strTarget = strTarget & strRec
72                    
73                End If
74                
75            Case "," '「"」が偶数なら区切り、奇数ならただの文字
76            
77                If lngQuote Mod 2 = 0 Then
78                    
79                    If targetColumn = 0 Then Call getTargetColumnIndex(currentColumn, targetColumn, strTarget, targetColName) '項目行なら判定行のインデックスを探す
80                    If currentRow > 1 And (currentColumn + 1) = targetColumn Then isAdd = Not isMemberInArr(targetKeyArr, strTarget)
81                    If isAdd Then Call pushValueToArr(strTarget, strArr()) '成型した文字列を配列に格納
82                    Call updateConditions(currentColumn, strTarget, lngQuote)  '列が変わる時の処理
83                    
84                Else
85                
86                    strTarget = strTarget & strRec
87                    
88                End If
89                
90            Case """" '「"」のカウントをとる
91            
92                lngQuote = lngQuote + 1
93                strTarget = strTarget & strRec
94                
95            Case Else
96            
97                strTarget = strTarget & strRec
98                
99        End Select
100        
101    Loop
102    
103    '最終セルの処理
104    If currentColumn > 0 And strTarget <> "" Then
105        
106        If (currentColumn + 1) = targetColumn Then isAdd = isMemberInArr(targetKeyArr, strTarget)
107        If isAdd Then Call pushValueToArr(strTarget, strArr) '成型した文字列を配列に格納
108        Call updateConditions(currentColumn, strTarget, lngQuote)  '列が変わる時の処理
109        
110    End If
111    
112    If Not Not strResults Then
113    
114        Call pushArrToCells(resultCSV.Worksheets(1), startR, dimenNum, strResults)
115    
116    End If
117    
118    resultCSV.Save
119    
120err2:
121    MsgBox (err.Description)
122    
123
124End Sub
125
126'対象列の値なら配列に追加する
127'①現在の列インデックス②対象の文字列③ダブルクォーテーションの数④対象列名⑤対象列インデックス⑥文字列配列
128Sub updateConditions(ByRef currentColumn As Long, ByRef strTarget As String, ByRef lngQuote As Long)
129
130    currentColumn = currentColumn + 1
131    lngQuote = 0
132    
133    strTarget = ""
134
135End Sub
136'項目列が判定列ならインデックスを返す
137Sub getTargetColumnIndex(ByVal currentColumn As Long, ByRef targetColumn As Long, ByVal strTarget As String, ByVal targetColName As String)
138
139    If editStrIsBlank(strTarget) = targetColName Then
140    
141        targetColumn = currentColumn + 1
142    
143    End If
144
145End Sub
146
147'空白なら""を、それ以外なら"を取った値に編集する
148Function editStrIsBlank(ByVal strTarget As String)
149
150    If Left(strTarget, 1) = """" And Right(strTarget, 1) = """" Then
151    
152        If Len(strTarget) <= 2 Then
153            
154            editStrIsBlank = ""
155            Exit Function
156                
157        Else
158            
159            editStrIsBlank = Mid(strTarget, 2, Len(strTarget) - 2)
160            Exit Function
161                
162        End If
163        
164    End If
165    
166    editStrIsBlank = strTarget
167
168End Function
169
170'文字列の"を削除、最大数を増やして1次元配列に値を入れる
171Sub pushValueToArr(ByVal strTarget As String, ByRef strArr() As String)
172
173    strTarget = Replace(strTarget, """""", """") '前後の「"」を削除
174    
175    strTarget = editStrIsBlank(strTarget) '空白なら""を、それ以外なら"を取った値に編集する
176    
177    If Not Not strArr Then '配列が初期化済みなら上限数を増やして追加する
178        
179        ReDim Preserve strArr(UBound(strArr) + 1)
180        
181    Else
182    
183        ReDim strArr(0)
184    
185    End If
186    
187    strArr(UBound(strArr)) = strTarget
188
189End Sub
190
191'1次元配列の値をすべて2次元配列に入れる（呼び出し元は最後にtransposeする）。1列目以降は次元数の横方向固定
192Sub pushArrToMDArr(strResults() As String, strArr() As String, ByRef dimenNum As Long, ByVal countColumn As Long)
193
194    Dim temp As Variant
195    Dim errA As Variant
196    
197    If countColumn = 100000 Then
198    
199        countColumn = UBound(strArr)
200        
201    End If
202
203    If Not Not strResults Then '配列が初期化済みなら上限数を増やして追加する
204    
205        dimenNum = dimenNum + 1
206        
207    End If
208    
209    ReDim Preserve strResults(countColumn, dimenNum)
210    
211    
212    For i = 0 To countColumn
213    
214        If i > UBound(strArr) Then
215        
216            strResults(i, dimenNum) = ""
217        
218        Else
219        
220            strResults(i, dimenNum) = strArr(i)
221            
222        End If
223    
224    Next i
225
226End Sub
227
228'指定要素が配列のメンバーかどうか返す
229Function isMemberInArr(targetKeyArr() As String, strTarget As String) As Boolean
230    
231    Dim result As Variant
232    
233    result = Filter(targetKeyArr(), strTarget)
234    
235    isMemberInArr = (UBound(result) <> -1)
236
237End Function
238
239'ワークブックを作る
240Function returnWB(path As String) As Workbook
241
242    Dim wbResult As Workbook
243    Set wbResult = Workbooks.Add
244    wbResult.SaveAs fileName:=path & "編集済データ.csv", _
245                    FileFormat:=xlCSV
246    
247    Set returnWB = wbResult
248
249End Function
250
251'2次元配列をシート内に突っ込む
252Function pushArrToCells(ByRef ws As Worksheet, ByVal startR As Long, ByVal dimenNum As Long, ByRef strResults() As String) As Long
253    
254    With ws
255    
256        .Range(.Cells(startR, 1), .Cells(dimenNum + startR, UBound(strResults) + 1)).value = WorksheetFunction.Transpose(strResults) '結果データを張り付ける
257    
258    End With
259    
260    Erase strResults
261                            
262    pushArrToCells = startR + dimenNum + 1
263    
264End Function
265

sazi

2021/04/21 03:44

> 行数がExcelで開く限りでは表示できない量の巨大なCSV それをVBAで貼り付けてもエクセルでは開けないサイズに編集しようとしたら同じことではないでしょうか。編集できたとしてもエクセルでは開けない事が分かっていて、その結果を使って何をしたいのですか？

hatena19

2021/04/21 03:48

> という処理をDoループで繰り返すことで実現しようとしていました。提示のコードには Doループはないですけど。再帰のような感じですが、そうでもないですし。ちゃんと動作するコードを提示してください。

kktok

2021/04/21 04:36

sazi様意図が伝わりづらく失礼しました。こちら、他の方が作ったツールで集計を行うにあたり、独自の集計を行いたいためCSVをそのツールに通す前に集計外となるデータを省いたCSVを作成したい、というのが目的です。元のツール作成者にお願いすることが難しかったため、別でツールを作成することになった次第です。

kktok

2021/04/21 04:37

hatena19様エラーの発生するコードのみ載せてしまい失礼いたしました。コード範囲を拡大させていただきましたので、改めてご確認ください。