■(続)複数CSVファイルのまとめ

■複数CSVファイルのまとめ の続きです。ネタが思い浮かばないので

前回
>#とりあえずオーソドックスな手法。1シート読み込み可能な行数を超えるケースは考慮せず。
と書きましたが、今度は1,000行x100csvファイル100,000件のデータをシート分割しながら読み込んでみます。

#1ファイルで65,536行超えるケースは考慮せず。
...とか書いて(続々)の前フリも一応しておこう。

でも2007が主流になれば考慮しなくてもいいもんねぇ（？）

Option Explicit
'---------------------------------------------------------------------
Private Sub prep()
　　'ThisWorkbook.Pathに1,000行x100csvのテスト用ファイル作成。
　　'ファイル上書きに要注意。
　　Const MX　 As Long = 1000
　　Const FX　 As Long = 100
　　Dim wkNAME As String
　　Dim i　　　As Long
　　Dim j　　　As Long
　　Dim n　　　As Long

　　wkNAME = ThisWorkbook.Path & "¥test"
　　ReDim tmp(1 To MX) As String
　　For j = 1 To FX
　　　　For i = 1 To MX
　　　　　　tmp(i) = "A" & i & "," _
　　　　　　　　& Chr(65 + Int(Rnd * 26)) & Hex(Int(Rnd * 10000)) _
　　　　　　　　& ",""" & Format(Int(Rnd * 10000), "#,###0") & """"
　　　　Next i
　　　　'For j = 1 To FX 'ファイルごとに内容を変えない場合はjのLoopはここ。
　　　　n = FreeFile
　　　　Open wkNAME & j & ".csv" For Output As #n
　　　　Print #n, Join(tmp, vbCrLf)
　　　　Close #n
　　Next j
End Sub
'---------------------------------------------------------------------
Private Sub try()
　　Dim ws　As Worksheet
　　Dim fd　As String
　　Dim fn　As String
　　Dim ret As String
　　Dim i　 As Long
　　Dim n　 As Long
　　Dim x　 As Long

　　fd = ThisWorkbook.Path & "¥"
　　'fd = FDSELECT 'フォルダ選択の場合

　　If Len(fd) = 0& Then Exit Sub
　　Application.ScreenUpdating = False
　　'ActiveWorkbookにシートを追加して処理
　　Set ws = Sheets.Add
　　On Error GoTo errHndler
　　fn = Dir(fd & "*.csv")

　　x = 1
　　Do Until Len(fn) = 0&
　　　　i = i + 1
　　　　'データCountにより次のセット先変更
　　　　n = n + x
　　　　'外部データ取り込み
　　　　x = CSVQRY(ws, fd & fn, ws.Cells(n, 2))
　　　　If x < 0 then
　　　　　　Err.Raise Number:=513, Description:="CSV読み込みに失敗"
　　　　ElseIf (n + x) >= Rows.Count Then
　　　　　　'行数overしてもエラーかからないため取り込み直し
　　　　　　ws.Rows(n).Resize(x).Delete
　　　　　　Set ws = Sheets.Add
　　　　　　n = 1
　　　　　　x = CSVQRY(ws, fd & fn, ws.Cells(n, 2))
　　　　End If
　　　　'ファイル名をA列にセット
　　　　ws.Cells(n, 1).Resize(x).Value = fn
　　　　fn = Dir()
　　Loop

　　If i > 0 Then
　　　　ret = i & "files.done"
　　Else
　　　　ret = "no file"
　　End If

errHndler:
　　If Err.Number <> 0 Then
　　　　ret = Err.Number & vbTab & Err.Description
　　　　Debug.Print ret
　　End If
　　Application.ScreenUpdating = True
　　MsgBox ret
　　Set ws = Nothing
End Sub
'---------------------------------------------------------------------
Private Function CSVQRY(ByRef ws As Worksheet, _
　　　　　　　　　　　　ByRef fs As String, _
　　　　　　　　　　　　ByRef rs As Range) As Long
　　Dim cnt As Long

　　On Error GoTo errChk
　　With ws.QueryTables.Add(Connection:="TEXT;" & fs, _
　　　　　　　　　　　　　　Destination:=rs)
　　　　.AdjustColumnWidth = False
　　　　.TextFilePlatform = xlWindows
　　　　.TextFileStartRow = 1
　　　　.TextFileCommaDelimiter = True
　　　　.Refresh False
　　　　cnt = .ResultRange.Rows.Count
　　　　.Parent.Names(.Name).Delete
　　　　.Delete
　　End With
　　CSVQRY = cnt
　　Exit Function
errChk:
　　CSVQRY = -1
End Function
'---------------------------------------------------------------------

Private Function FDSELECT() As String 'フォルダ選択Function
　　Dim obj As Object
　　Dim ret As String

　　Set obj = CreateObject("Shell.Application") _
　　　　　　　.BrowseForFolder(0, "SelectFolder", 0)
　　If obj Is Nothing Then Exit Function
　　On Error Resume Next
　　ret = obj.self.Path & "¥"
　　If Err.Number <> 0 Then
　　　　ret = obj.Items.Item.Path & "¥"
　　　　Err.Clear
　　End If
　　On Error GoTo 0
　　Set obj = Nothing
　　FDSELECT = ret
End Function

#gooアドバンス切り替え準備中です。3月に引越します。
#見てる方いらっしゃるのかわかんないけど、一応お知らせ。