Excel VBA で CSVを読み込んで結合する

Option Explicit

' フォルダの選択
Private Sub CommandButton1_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Me.TextBox1.Text = .SelectedItems(1)
        End If
    End With
End Sub

' CSV結合の実行
Private Sub CommandButton2_Click()
    
    Me.CommandButton2.Enabled = False
    Application.ScreenUpdating = False
    
    ' 取込み設定の確認
    Dim MODE_Sheet分割 As Boolean
    Dim MODE_FILENAME_1行目 As Boolean
    Dim MODE_FILENAME_AB列 As Boolean
    If Me.OptionButton1.Value Then
        MODE_Sheet分割 = False
        MODE_FILENAME_1行目 = False
        MODE_FILENAME_AB列 = True
    ElseIf Me.OptionButton2.Value Then
        MODE_Sheet分割 = False
        MODE_FILENAME_1行目 = False
        MODE_FILENAME_AB列 = False
    ElseIf Me.OptionButton3.Value Then
        MODE_Sheet分割 = False
        MODE_FILENAME_1行目 = True
        MODE_FILENAME_AB列 = False
    ElseIf Me.OptionButton4.Value Then
        MODE_Sheet分割 = True
        MODE_FILENAME_1行目 = False
        MODE_FILENAME_AB列 = False
    ElseIf Me.OptionButton5.Value Then
        MODE_Sheet分割 = True
        MODE_FILENAME_1行目 = True
        MODE_FILENAME_AB列 = False
    End If
    Dim MODE_SUBDIR As Boolean
    MODE_SUBDIR = Me.CheckBox1.Value
    Dim MODE_SUBSHEET As Boolean
    MODE_SUBSHEET = Me.CheckBox2.Value
    
    ' フォルダの存在チェック
    Dim fso As New FileSystemObject
    If Not fso.FolderExists(TextBox1.Text) Then
        MsgBox "フォルダが存在しません"
        Exit Sub
    End If
        
    ' ＊＊＊処理開始＊＊＊
    ' Workbookを追加
    Dim b As Workbook
    Set b = Workbooks.Add
    ' 不要なシートを削除
    Dim i As Integer
    Application.DisplayAlerts = False
    Dim sCount As Long
    sCount = b.Sheets.count
    For i = 2 To sCount
        b.Sheets(2).Delete
    Next
    b.Sheets(1).Name = "Sheet1"
    Application.DisplayAlerts = True
    ' フォルダの探索・CSVファイル取り込みを開始
    ThisWorkbook.Activate
    Call GetSubFolderCSV(b, b.Sheets(1).Range("A1"), fso.GetFolder(TextBox1.Text), MODE_SUBDIR, MODE_SUBSHEET, MODE_Sheet分割, MODE_FILENAME_AB列, MODE_FILENAME_1行目, fso.GetFolder(TextBox1.Text))
    
    '完了
    Me.CommandButton2.Enabled = True
    Me.Hide
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "完了しました。"
End Sub

' フォルダを探索してCSVファイルがあれば，CSVの取り込み関数へ渡す。
'       book As Workbook, 読み込み先のブック _
        ByRef r As Range, 読み込み先のセル _
        dir As Folder, 読み込むフォルダ _
        m_subdir As Boolean, サブディレクトリを探索するかどうか _
        m_subsheet As Boolean, ワークシートの上限を超える場合に次のシートを追加して処理を継続するか _
        m_sheet分割 As Boolean, CSVファイルごとにシートを分割するか _
        m_fn_col_AB As Boolean, A・B列にフォルダパス・ファイル名を追加するか _
        m_fn_1strow As Boolean, 1行目にファイルパスを追加するか _
        base_dir As Folder　基準フォルダ（シート名にファイルの相対パスを設定する際に使用）
Sub GetSubFolderCSV( _
        book As Workbook, _
        ByRef r As Range, _
        dir As Folder, _
        m_subdir As Boolean, _
        m_subsheet As Boolean, _
        m_sheet分割 As Boolean, _
        m_fn_col_AB As Boolean, _
        m_fn_1strow As Boolean, _
        base_dir As Folder)
    Dim f As File
    Dim d As Folder
    Dim sh As Worksheet
    Set sh = book.Sheets(1)
    ' フォルダ内のファイルを探索
    For Each f In dir.Files
        ' 拡張子がCSVなら処理する
        If f.Name Like "*.csv" Then
            If m_sheet分割 Then ' CSVファイルごとにシート分割する場合
                If book.Sheets.count = 1 Then
                    If book.Sheets(1).Name = "Sheet1" Then
                        Set sh = book.Sheets(1) ' 最初のシートはそのまま使う
                    Else
                        Set sh = book.Sheets.Add(After:=book.Sheets(book.Sheets.count)) ' 2つめ以降はシートを末尾に追加
                    End If
                Else
                    Set sh = book.Sheets.Add(After:=book.Sheets(book.Sheets.count)) ' 2つめ以降はシートを末尾に追加
                End If
                ' シート名の変更
                If m_fn_1strow Then
                    ' 1行目にファイルパスを出力する設定の場合はシート名は単純にシート番号とする
                    sh.Name = book.Sheets.count
                Else
                    ' シート名をファイルパスとする場合は，相対パスを付ける。
                    ChangeSheetName sh, f.path, base_dir.path
                End If
                ' シートの先頭を出力先セルとする
                Set r = sh.Range("A1")
            Else
                ' シート分割しない場合はシート名はCSVとする。
                sh.Name = "CSV"
            End If
            ' 1行目にファイルパスを入力する
            If m_fn_1strow Then
                sh.Cells(r.Row, 1).Formula = f.path
                Set r = r.Offset(1, 0)
            End If
            ' CSVを取り込む
            Dim count As Long
            Windows(book.Name).WindowState = xlMinimized
            DoEvents
            count = CsvToRange(r, f, m_fn_col_AB, m_subsheet)
        End If
    Next
    ' サブディレクトリを再帰的に探索
    If m_subdir Then
        For Each d In dir.SubFolders
            Call GetSubFolderCSV(book, r, d, m_subdir, m_subsheet, m_sheet分割, m_fn_col_AB, m_fn_1strow, base_dir)
        Next
    End If
End Sub

' Worksheetの名前を相対パスとする _
    sh As Worksheet: worksheet _
    fPath As String: ファイルパス（絶対パス） _
    dPath As String: フォルダパス（基準ディレクトリ）
Sub ChangeSheetName(sh As Worksheet, fPath As String, dPath As String)
    
    ' Worksheetの名前には31文字制限がありファイルパスが長すぎる場合は名前が重複する場合がある
    ' その場合に末尾に~1,~2,~3,…,~A,~B,~C,…,~a,~b,~c,…~zを付けて名前の重複を回避する。
    Dim indx(0 To 61) As String
    Dim i As Integer
    indx(0) = ""
    For i = 1 To 9
        indx(i) = "~" & Chr(Asc("1") + i - 1)
    Next
    For i = 10 To 35
        indx(i) = "~" & Chr(Asc("A") + i - 10)
    Next
    For i = 36 To 61
        indx(i) = "~" & Chr(Asc("a") + i - 36)
    Next
    
    ' 相対パスの取得
    Dim rPath As String
    rPath = Mid(GetRelativePath(dPath, fPath), 3)
    
    ' 禁則文字の削除
    rPath = Replace(rPath, "\", "|") ' フォルダ区切りは | に置き換える
    rPath = Replace(rPath, "?", "")
    rPath = Replace(rPath, ":", "")
    rPath = Replace(rPath, "[", "")
    rPath = Replace(rPath, "]", "")
    rPath = Replace(rPath, "/", "")
    rPath = Replace(rPath, "*", "")
    rPath = Replace(rPath, "'", "")
    rPath = Replace(rPath, "￥", "")
    
    Dim sheetName As String
    sheetName = Left(Right(rPath, 29 + 4), 29) ' 拡張子を除いて末尾29文字を取得し，これをシート名とする。
    
    ' 重複の判断はシート名変更の成否で判断
    i = 0
    Dim sheetNameChanged As Boolean
    sheetNameChanged = False
    On Error Resume Next
    Do While sheetNameChanged = False
        sh.Name = sheetName & indx(i)
        If Err.Number = 0 Then
            sheetNameChanged = True
        Else
            i = i + 1 ' Err.Number <> 0 の時はシート名の変更でエラーが出ているので，添え字をカウントアップする。
            If i > 61 Then
                MsgBox "シート名に付ける添え字がオーバーフローしました。重複するシート名となるファイル名を減らしてください。" ' 61超えるのは想定していない。
                Stop
            End If
            Err.Clear
        End If
    Loop
    On Error GoTo 0
End Sub

Option Explicit

' https://excel-ubara.com/excelvba5/EXCELVBA271.html を参考に作成
' CSVの読み込み方法（ジャグ配列）（改）
' Redim Preserve などの重い処理は極力回避して高速に処理できるように配慮

' 1列読み込み時の格納セル
' Excel2013のワークシートの最大列数である16384列としてある。
' putjagArrayにて使用。putjagArrayでも16384を超える場合は処理中止するようにしている。
Private Const COLUMN_MAX As Long = 16384
Private colArray(1 To COLUMN_MAX) As Variant

'CSVファイルを指定のセルから出力する（戻り値は出力した行数）
'                      ByRef r As Range,　出力先のセル。出力後は次に出力すべきセルが設定される
'                      ByVal f As File,　 CSVファイル
'                      Optional ByVal AddFileInfo As Boolean = False,　これがTrueのとき，A,B列にはフォルダパスおよびファイル名を出力する
'                      Optional ByVal UseSubSheet As Boolean = False,　これがTrueのとき，ワークシートの最終行まで出力したら次のワークシートを作成して出力する
'                      Optional ByVal CharSet As String = "Auto") As Long　文字コードの指定
'                      文字コードの種類は"SHIFT-JIS","EUC-JP","UTF-8N","UTF-8","UTF-16 LE","UTF-16 BE","UTF-32 LE","UTF-32 BE"
Public Function CsvToRange( _
                      ByRef r As Range, _
                      ByVal f As File, _
                      Optional ByVal AddFileInfo As Boolean = False, _
                      Optional ByVal UseSubSheet As Boolean = False, _
                      Optional ByVal CharSet As String = "Auto") As Long
    ' AddFileInfoする場合はCSV出力の列をC列からとする必要がある
    Dim colOffset As Integer ' CSV出力先のオフセット
    If AddFileInfo Then
        colOffset = 2
    Else
        colOffset = 0
    End If
    
    Debug.Print f.path
    Debug.Print " 000_Start:" & Timer & " sec."
    Application.StatusBar = Right(f.path, 64) & "..." & "CSVファイルの読み込み中"
    DoEvents
    
    'readCsvでCSVを読み込み。文字コードチェックもここで行われる。
    Dim strRec As String ' CSVファイルの文字列データ
    strRec = readCsv(f.path, CharSet)
  
    Debug.Print " 100_StartCSVToJagged:" & Timer & " sec."
    Application.StatusBar = Right(f.path, 64) & "..." & "CSVファイルの解析中"
    DoEvents
    
    'CsvToJaggedで行・列に分割してジャグ配列に
    Dim jagRows As Long ' ジャグ配列の行数を受取る
    Dim jaggedArray() As Variant ' ジャグ配列
    jaggedArray = CsvToJagged(strRec, jagRows, UseSubSheet)
    strRec = ""
  
    Debug.Print " 200_StartJaggedTo2D:" & Timer & " sec."
    Application.StatusBar = Right(f.path, 64) & "..." & "Excelワークシートに書込み中"
    DoEvents
    
    'JaggedTo2Dでジャグ配列を2次元配列に変換
    Dim myArray() As Variant ' 2次元配列
    Call JaggedTo2D(jaggedArray, jagRows, myArray)
    Erase jaggedArray
  
    Debug.Print " 300_StartSetExcelSheet:" & Timer & " sec."
    
    '2次元配列→セルへ書き込み
    '最大列数のチェック
    If r.Column + colOffset + UBound(myArray, 2) > Columns.count Then
        MsgBox "Excelの最大列数(" & Columns.count & "列)を超えました。" & vbCrLf & r.Column + UBound(myArray, 2)
        Stop
    End If
    '最大行数のチェック
    If r.Row + UBound(myArray, 1) >= Rows.count Then
        '最大行を超えた場合は，次のシートへ行くかどうか判定
        If UseSubSheet Then
            '次のシートへ行く必要がある。まずはこのシートに出力できる分を出力しておく。
            Debug.Print " 301_AddSubSheet:" & Timer & " sec."
            Dim index As Integer ' 追加されるシートの枚数。最大で61までとしている。
            Dim partArray() As Variant 'このシートで出力しておくべき部分を格納する部分配列
            Dim partUBound As Long '部分配列に格納された元の2次元配列の範囲（最大値）
            Dim partLBound As Long '部分配列に格納された元の2次元配列の範囲（最小値）
            Dim partLBound_1 As Long '部分配列に格納された元の2次元配列の範囲（最小値-1）
            Dim partArrayCount As Long '部分配列の行数
            Dim i As Long
            Dim j As Long
            partLBound = 1
            partUBound = 0
            index = 0
            Do While partUBound < UBound(myArray, 1) ' すべての配列の中身を出力し終わるまで繰り返す
                Debug.Print " 301_AddSubSheet:" & Timer & " sec."
                DoEvents
                ' 最終行までに残りの部分が全て出力できるか。
                If UBound(myArray, 1) - partUBound < Rows.count - r.Row Then
                    partUBound = UBound(myArray, 1) ' できるなら最後まで
                Else
                    partUBound = partLBound - r.Row + Rows.count - 1 ' できないなら最終行-1まで
                End If
                ' 部分配列の確保とコピー
                partArrayCount = partUBound - partLBound + 1
                partLBound_1 = partLBound - 1
                ReDim partArray(1 To partArrayCount, UBound(myArray, 2))
                For i = 1 To partArrayCount
                    For j = 1 To UBound(myArray, 2)
                        partArray(i, j) = myArray(partLBound_1 + i, j)
                    Next
                Next
                ' 出力
                r.Offset(0, colOffset).Resize(UBound(partArray, 1), UBound(partArray, 2)) = partArray
                ' フォルダパスとファイル名の出力
                If AddFileInfo Then
                    r.Offset(0, 0).Resize(UBound(partArray, 1), 1) = f.ParentFolder.path
                    r.Offset(0, 1).Resize(UBound(partArray, 1), 1) = f.Name
                End If
                ' 出力完了したのでセルを次の出力先にセット
                Set r = r.Offset(partArrayCount, 0)
                ' 次の出力先＝最終行になっていた場合は，Worksheet追加して次のシートに次の出力先を設定
                If r.Row = Rows.count Then
                    Dim sh As Worksheet
                    index = index + 1
                    Set sh = AddSubSheet(r.Worksheet.Parent, r.Worksheet.Name, index) ' シートの追加とシート名の設定を行う
                    Set r = sh.Cells(1, r.Column)
                    Application.StatusBar = Right(f.path, 64) & "..." & "Excelワークシートを追加して書込み中"
                End If
                ' 次に格納する2次元配列の下限を設定
                partLBound = partUBound + 1
            Loop
        Else
            ' 次のシートは使わないので中止
            MsgBox "Excelの最大行数(" & Rows.count & "行)を超えました。" & vbCrLf & r.Row + UBound(myArray, 1)
            Stop
        End If
    Else
        ' 最大行を超えていないのでそのまま出力する
        r.Offset(0, colOffset).Resize(UBound(myArray, 1), UBound(myArray, 2)) = myArray
        ' フォルダパスとファイル名の出力
        If AddFileInfo Then
            r.Offset(0, 0).Resize(UBound(myArray, 1), 1) = f.ParentFolder.path
            r.Offset(0, 1).Resize(UBound(myArray, 1), 1) = f.Name
        End If
        ' 出力完了したのでセルを次の出力先にセット
        Set r = r.Offset(UBound(myArray, 1), 0)
    End If
        
    
    Debug.Print " 400_EndSetExcelSheet:" & Timer & " sec."
    CsvToRange = UBound(myArray, 1)
    Erase myArray
    Debug.Print " 500_Complete:" & Timer & " sec."
End Function

' シートの追加とシート名の設定を行う
' book As Workbook, シートを追加するワークブック
' shName As String, シート名
' index As Integer　シート名につける添え字を生成するための数字。これに基づき ~1,~2,~3,…,~A,~B,~C,…,~a,~b,~c,…~zまでの添え字をつける。最大値は61
Private Function AddSubSheet(book As Workbook, shName As String, index As Integer) As Worksheet
    Dim indx(0 To 61) As String
    ' 入力チェック
    If index > 61 Then
        MsgBox "シート数に付ける添え字がオーバーフローしました。"
        Stop
    ElseIf index < 0 Then
        Stop
    End If
    Dim i As Integer
    ' 添え字初期化
    indx(0) = ""
    For i = 1 To 9
        indx(i) = "~" & Chr(Asc("1") + i - 1)
    Next
    For i = 10 To 35
        indx(i) = "~" & Chr(Asc("A") + i - 10)
    Next
    For i = 36 To 61
        indx(i) = "~" & Chr(Asc("a") + i - 36)
    Next
    ' Worksheetの追加と名前の変更
    Dim sh As Worksheet
    Set sh = book.Sheets.Add(After:=book.Sheets(book.Sheets.count))
    sh.Name = Right(shName, 29) & indx(index)
    Set AddSubSheet = sh
End Function

'ジャグ配列を2次元配列に変換
'                       ByRef jagArray() As Variant, ' ジャグ配列
'                       ByVal jagRows As Long,       ' ジャグ配列の行数を受取る
'                       ByRef twoDArray As Variant)  ' 2次元配列を返す
Private Sub JaggedTo2D( _
                       ByRef jagArray() As Variant, _
                       ByVal jagRows As Long, _
                       ByRef twoDArray As Variant)
    'ジャグ配列の最大列数取得
    Debug.Print " 210_JaggedTo2D_GetMaxCol:" & Timer & " sec."
    Dim maxCol As Long, v As Variant
    Dim i As Long
    maxCol = 0
    For i = 1 To jagRows
        If UBound(jagArray(i)) > maxCol Then
            maxCol = UBound(jagArray(i))
        End If
    Next
  
    'ジャグ配列→2次元配列
    Debug.Print " 211_JaggedTo2D_Make2DArray:" & Timer & " sec."
    Dim i1 As Long, i2 As Long
    ReDim twoDArray(1 To jagRows, 1 To maxCol)
    For i1 = 1 To jagRows
        For i2 = 1 To UBound(jagArray(i1))
            twoDArray(i1, i2) = jagArray(i1)(i2)
        Next
    Next
End Sub

' CSVの文字列をジャグ配列にして返す
'                             ByRef strRec As String,  CSV(文字列データ)
'                             ByRef jagRows As Long) ジャグ配列の行数を返す
'                             As Variant()　ジャグ配列を返す
Private Function CsvToJagged( _
                             ByRef strRec As String, _
                             ByRef jagRows As Long, _
                             ByVal UseSubSheet As Boolean) _
                             As Variant()
    Dim lngQuate As Long 'ダブルクォーテーションの数（この関数内でカウントアップされ，putcolArray関数内でリセットされる）
    Dim strCell As New StringBuilder '1フィールド文字列（この関数内で文字列が追加され，putcolArray関数内でクリアされる）
    Dim i As Long '行位置
    Dim j As Long '列位置（putcolArray関数内でカウントアップされ，putjagArray関数内でリセットされる）
    Dim k As Long
    ' CSV文字列長
    Dim lenStrRec As Long
    lenStrRec = Len(strRec)
    ' ステータスバー表示用
    Dim dispk As Long
    dispk = lenStrRec / 20
    Dim disppercent As Integer
    
    Dim c As String ' 分析中の文字
    Dim d As String ' cの1文字前
 
    ReDim CsvToJagged(1 To Rows.count) 'ジャグ配列の初期化（ReDim Preserveは処理が遅いのでExcelのシートで取り扱える最大行数としている。）
    
    i = 1 'シートの1行目から出力
    j = 0 '列位置（putcolArray関数内でカウントアップされ，putjagArray関数内でリセットされる）
    lngQuate = 0 'ダブルクォーテーションの数（この関数内でカウントアップされ，putcolArray関数内でリセットされる）
    
    ' ステータスバー表示用
    Dim stat_len As Integer
    stat_len = Len(Application.StatusBar)
    disppercent = 0
    Application.StatusBar = Left(Application.StatusBar, stat_len) & " [0%]"
    DoEvents
    
    For k = 1 To lenStrRec
        
        ' ステータスバー表示用
        If k Mod dispk = 0 Then
            disppercent = disppercent + 5
            Application.StatusBar = Left(Application.StatusBar, stat_len) & " [" & disppercent & "%] (" & k & "/" & lenStrRec & ")"
            DoEvents
        End If
        
        c = Mid(strRec, k, 1)
        Select Case c
            Case vbCr '「"」が偶数なら改行、奇数ならただの文字
                If lngQuate Mod 2 = 0 Then
                    Call putcolArray(j, strCell, lngQuate) ' 列を挿入
                    Call putjagArray(CsvToJagged, i, j, lngQuate, strCell, UseSubSheet) ' 行を挿入
                Else
                    strCell.Append1 c ' 文字を追加
                End If
            Case vbLf '「"」が偶数なら改行、奇数ならただの文字
                If lngQuate Mod 2 = 0 Then
                    If d <> vbCr Then '前の文字が CR の場合はCRLFであり，CRの処理にてやるべきことは完了しているので無視する
                        Call putcolArray(j, strCell, lngQuate) ' 列を挿入
                        Call putjagArray(CsvToJagged, i, j, lngQuate, strCell, UseSubSheet) ' 行を挿入
                    End If
                Else
                    strCell.Append1 c ' 文字を追加
                End If
            Case "," '「"」が偶数なら区切り、奇数ならただの文字
                If lngQuate Mod 2 = 0 Then
                    Call putcolArray(j, strCell, lngQuate) ' 列を挿入
                Else
                    strCell.Append1 c ' 文字を追加
                End If
            Case """" '「"」のカウントをとる
                lngQuate = lngQuate + 1
                strCell.Append1 c ' 文字を追加
            Case Else
                strCell.Append1 c ' 文字を追加
        End Select
        d = c
    Next
  
    '最終行の最終列の処理
    If j > 0 And strCell.length <> 0 Then
        Call putcolArray(j, strCell, lngQuate) ' 列を挿入
        Call putjagArray(CsvToJagged, i, j, lngQuate, strCell, UseSubSheet) ' 行を挿入
    End If
    
    jagRows = i - 1 'ジャグ配列の行数を返す
End Function

' CSVの行を挿入(ジャグ配列に追加する)
'                       ByRef jagArray() As Variant, ジャグ配列 _
                        ByRef i As Long, 追加するジャグ配列の行番号 _
                        ByRef j As Long, 追加される列配列の長さ（ここでリセットされる） _
                        ByRef lngQuate As Long, 'ダブルクォーテーション数(ここでリセットしている) _
                        ByRef strCell As StringBuilder) フィールド文字列(ここでクリアしている) _
                        ByVal UseSubSheet As Boolean) ワークシートの上限を超える場合True
Private Sub putjagArray(ByRef jagArray() As Variant, _
                        ByRef i As Long, _
                        ByRef j As Long, _
                        ByRef lngQuate As Long, _
                        ByRef strCell As StringBuilder, _
                        ByVal UseSubSheet As Boolean)
    
    If j > COLUMN_MAX Then
        ' 列配列の最大長を超えるので中止
        MsgBox "Excelの最大列数(" & COLUMN_MAX & "列)を超えました。" & vbCrLf & "(" & j & "列目が入力されました)"
        Stop
    Else
        If UseSubSheet Then ' もしワークシートの上限である行数を超えても良い設定がされており
            If i > UBound(jagArray) Then ' 実際にワークシートの上限を超える行数が入力された場合
                ReDim Preserve jagArray(1 To i + Rows.count) ' 配列の長さを増やす。（Excelのシートで取り扱える最大行数分だけ追加）（未テスト）
            End If
        End If
        ' ジャグ配列へ格納する子配列の作成
        Dim childArray() As Variant
        ReDim childArray(1 To j)
        '子配列をジャグ配列に入れる
        jagArray(i) = childArray ' もししワークシートの上限である行数を超えても良い設定がされておらず，上限を超える行数が入力された場合はここエラーになります。（手抜きで例外は拾ってない）
        Erase childArray
        ' 列配列からのコピー
        Dim k As Long
        For k = 1 To j
            jagArray(i)(k) = colArray(k)
        Next
    End If
    
    i = i + 1 '行番号のカウントアップ
    j = 0 '列位置のリセット
    lngQuate = 0 'ダブルクォーテーション数のリセット
    strCell.Clear '1フィールド文字列のクリア
End Sub

'CSVの列を挿入(列配列へのフィールドの追加)
'                       ByRef j As Long, 追加先の列番号マイナス１（ここでカウントアップする） _
                        ByRef strCell As StringBuilder, 追加するフィールド文字列（これは，クリアして返す） _
                        ByRef lngQuate As Long ' ダブルクオーテーションの数（ここでリセットされる） )
Private Sub putcolArray(ByRef j As Long, _
                        ByRef strCell As StringBuilder, _
                        ByRef lngQuate As Long)
    ' 列番号のカウントアップ
    j = j + 1
    ' フィールド文字列の設定
    Dim s As String
    Dim lens As Long
    s = strCell.ToString
    lens = strCell.length
    ' フィールド文字列のクリア
    strCell.Clear
    
    '前後の「"」を削除
    If Left(s, 1) = """" And Right(s, 1) = """" Then
        If lens <= 2 Then
            s = ""
        Else
            s = Mid(s, 2, lens - 2)
        End If
        lngQuate = lngQuate - 2
    End If
    
    '「""」を「"」で置換
    If lngQuate >= 2 Then
        s = Replace(s, """""", """")
    End If
    
    colArray(j) = s 'CSVの列を挿入(列配列へのフィールドの追加)
    lngQuate = 0 ' ダブルクオーテーションの数をリセット

End Sub

'文字コードを自動判別Stringに入れる
Private Function readCsv(ByVal strFile As String, _
                         ByVal CharSet As String) As String
'　　Dim objFSO As New FileSystemObject
'　　Dim inTS As TextStream
'　　Dim adoSt As New ADODB.Stream
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim inTS As Object
    Dim adoSt As Object
    Set adoSt = CreateObject("ADODB.Stream")
  
    Dim strRec As String
    Dim i As Long
    Dim aryRec() As String
 
    Debug.Print " 010_StartGetCharSet:" & Timer & " sec."
    If CharSet = "Auto" Then
        CharSet = getCharSet(strFile)
    End If
    
    Debug.Print " 020_StartReadingCSV:" & Timer & " sec."
    Application.StatusBar = strFile & "..." & "CSVファイルの読み込み中(" & CharSet & ")"
    DoEvents
    Select Case UCase(CharSet)
        Case "UTF-8", "UTF-8N"
            'ADOを使って読込、その後の処理を統一するため全レコードをCrLfで結合
            'Set inTS = objFSO.OpenTextFile(strFile, ForAppending)
            Set inTS = objFSO.OpenTextFile(strFile, 8)
            i = inTS.Line - 1
            inTS.Close
            ReDim aryRec(i)
            With adoSt
                '.Type = adTypeText
                .Type = 2
                .CharSet = "utf-8"
                .Open
                .LoadFromFile strFile
                i = 0
                Do While Not (.EOS)
                    'aryRec(i) = .ReadText(adReadLine)
                    aryRec(i) = .ReadText(-2)
                    i = i + 1
                Loop
                .Close
                strRec = Join(aryRec, vbCrLf)
            End With
        Case "EUC-JP" 'EUC-JPはADOで読み込めると思うけど未テスト
            Set inTS = objFSO.OpenTextFile(strFile, 8)
            i = inTS.Line - 1
            inTS.Close
            ReDim aryRec(i)
            With adoSt
                '.Type = adTypeText
                .Type = 2
                .CharSet = "euc-jp"
                .Open
                .LoadFromFile strFile
                i = 0
                Do While Not (.EOS)
                    'aryRec(i) = .ReadText(adReadLine)
                    aryRec(i) = .ReadText(-2)
                    i = i + 1
                Loop
                .Close
                strRec = Join(aryRec, vbCrLf)
            End With
        Case "UTF-16 LE", "UTF-16 BE"
            'Set inTS = objFSO.OpenTextFile(strFile, , , TristateTrue)
            Set inTS = objFSO.OpenTextFile(strFile, , , -1)
            strRec = inTS.ReadAll
            inTS.Close
        Case "SHIFT-JIS"
            Set inTS = objFSO.OpenTextFile(strFile)
            strRec = inTS.ReadAll
            inTS.Close
        Case Else
            ' UTF-32 LE,UTF-32 BEについては未実装
            ' 文字コードが分からないときは _autodetect で読んでみても良いかも。
            MsgBox "文字コードを確認してください。" & vbLf & CharSet
            Stop
            ' _autodetect を試す場合は F5キーを押して継続してね。
            Set inTS = objFSO.OpenTextFile(strFile, 8)
            i = inTS.Line - 1
            inTS.Close
            ReDim aryRec(i)
            With adoSt
                '.Type = adTypeText
                .Type = 2
                .CharSet = "_autodetect"
                .Open
                .LoadFromFile strFile
                i = 0
                Do While Not (.EOS)
                    'aryRec(i) = .ReadText(adReadLine)
                    aryRec(i) = .ReadText(-2)
                    i = i + 1
                Loop
                .Close
                strRec = Join(aryRec, vbCrLf)
            End With
            MsgBox Left(strRec, 256)
            Stop
            ' どうかな？読み込めたかな？
    End Select
    Set inTS = Nothing
    Set objFSO = Nothing
    Set adoSt = Nothing
    readCsv = strRec
End Function

'文字コードの自動判別
Private Function getCharSet(strFileName As String) As String
    Application.StatusBar = strFileName & "..." & "CSVファイルの読み込み中(文字コード解析中)"
    DoEvents
    
    Dim bytes() As Byte
    Dim intFileNo As Integer
    
    Debug.Print " 011_GetCharset_StartReadFile:" & Timer & " sec."
    ' 時間かかるので先頭64KBで判定する。
    If FileLen(strFileName) > 65535 Then
        ReDim bytes(65535)
    Else
        ReDim bytes(FileLen(strFileName))
    End If
    ' ファイル読み込み(先頭64KBのみ)
    intFileNo = FreeFile
    Open strFileName For Binary As #intFileNo
    Get #intFileNo, , bytes
    Close intFileNo
  
    Debug.Print " 012_GetCharset_FromBOM:" & Timer & " sec."
    'BOMによる判断
    getCharSet = getCharFromBOM(bytes)
  
    'BOMなしをデータの文字コードで判別
    If getCharSet = "" Then
        Debug.Print " 013_GetCharset_FromCode:" & Timer & " sec."
        getCharSet = getCharFromCode(bytes)
    End If
    
    Erase bytes
  
    Debug.Print " 014_GetCharset_Complete(" & getCharSet & "):" & Timer & " sec."
End Function

'文字コードの自動判別(BOMによる判断)
Private Function getCharFromBOM(ByRef bytes() As Byte) As String
    getCharFromBOM = ""
    If UBound(bytes) < 3 Then Exit Function
  
    Select Case True
        Case bytes(0) = &HEF And _
             bytes(1) = &HBB And _
             bytes(2) = &HBF
            getCharFromBOM = "UTF-8"
            Exit Function
        Case bytes(0) = &HFF And _
             bytes(1) = &HFE
             If bytes(2) = &H0 And _
                bytes(3) = &H0 Then
                getCharFromBOM = "UTF-32 LE"
                Exit Function
            End If
            getCharFromBOM = "UTF-16 LE"
            Exit Function
        Case bytes(0) = &HFE And _
             bytes(1) = &HFF
            getCharFromBOM = "UTF-16 BE"
            Exit Function
        Case bytes(0) = &H0 And _
             bytes(1) = &H0 And _
             bytes(2) = &HFE And _
             bytes(3) = &HFF
            getCharFromBOM = "UTF-32 BE"
            Exit Function
    End Select
End Function

'文字コードの自動判別(BOMなしデータから推定)
'以下は下記サイトのコードをVBAに移植
'https://dobon.net/vb/dotnet/string/detectcode.html
'BOMなしをデータの文字コードで判別⇒"SHIFT-JIS","UTF-8N","EUC-JP"
'これは元はJcode.pmのgetcodeメソッドを移植したものです。
''' Jcode.pm(http://openlab.ring.gr.jp/Jcode/index-j.html)
''' Jcode.pmの著作権情報
''' Copyright 1999-2005 Dan Kogai <dankogai@dan.co.jp>
''' This library is free software; you can redistribute it and/or modify it
'''  under the same terms as Perl itself.
Private Function getCharFromCode(ByRef bytes() As Byte) As String
    Const bEscape As Byte = &H1B
    Const bAt As Byte = &H40
    Const bDollar As Byte = &H24
    Const bAnd As Byte = &H26
    Const bOpen As Byte = &H28
    Const bB As Byte = &H42
    Const bD As Byte = &H44
    Const bJ As Byte = &H4A
    Const bI As Byte = &H49
    Dim bLen As Long: bLen = UBound(bytes)
    Dim b1 As Byte, b2 As Byte, b3 As Byte, b4 As Byte
    Dim isBinary As Boolean: isBinary = False
    Dim i As Long
  
    For i = 0 To bLen - 1
        b1 = bytes(i)
        If b1 <= &H6 Or b1 = &H7F Or b1 = &HFF Then
            ' binary
            isBinary = True
            If b1 = &H0 And i < bLen - 1 And bytes(i + 1) <= &H7F Then
                'smells like raw unicode
                getCharFromCode = "SHIFT-JIS"
                Exit Function
            End If
        End If
    Next
    If isBinary Then
        getCharFromCode = ""
        Exit Function
    End If

    ' Not Japanese (ASCII)
    Dim notJapanese As Boolean
    notJapanese = True
    For i = 0 To bLen - 1
        b1 = bytes(i)
        If b1 = bEscape Or &H80 <= b1 Then
            notJapanese = False
            Exit For
        End If
    Next
    If notJapanese Then
        getCharFromCode = "SHIFT-JIS"
        Exit Function
    End If

    For i = 0 To bLen - 3
        b1 = bytes(i)
        b2 = bytes(i + 1)
        b3 = bytes(i + 2)
        If b1 = bEscape Then
            If b2 = bDollar And b3 = bAt Then
                'JIS_0208 1978
                getCharFromCode = "SHIFT-JIS"
                Exit Function
            ElseIf b2 = bDollar And b3 = bB Then
                'JIS_0208 1983
                getCharFromCode = "SHIFT-JIS"
                Exit Function
            ElseIf b2 = bOpen And (b3 = bB Or b3 = bJ) Then
                'JIS_ASC
                getCharFromCode = "SHIFT-JIS"
                Exit Function
            ElseIf b2 = bOpen And b3 = bI Then
                'JIS_KANA
                getCharFromCode = "SHIFT-JIS"
                Exit Function
            End If
            If i < bLen - 3 Then
                b4 = bytes(i + 3)
                If b2 = bDollar And b3 = bOpen And b4 = bD Then
                    'JIS_0212
                    getCharFromCode = "SHIFT-JIS"
                    Exit Function
                End If
                If i < bLen - 5 And _
                    b2 = bAnd And b3 = bAt And b4 = bEscape And _
                    bytes(i + 4) = bDollar And bytes(i + 5) = bB Then
                    'JIS_0208 1990
                    getCharFromCode = "SHIFT-JIS"
                    Exit Function
                End If
            End If
        End If
    Next

    'should be euc|sjis|utf8
    'use of (?:) by Hiroki Ohzaki <ohzaki@iod.ricoh.co.jp>
    Dim sjis As Long: sjis = 0
    Dim euc As Long: euc = 0
    Dim utf8 As Long: utf8 = 0
    For i = 0 To bLen - 2
        b1 = bytes(i)
        b2 = bytes(i + 1)
        If ((&H81 <= b1 And b1 <= &H9F) Or (&HE0 <= b1 And b1 <= &HFC)) And _
           ((&H40 <= b2 And b2 <= &H7E) Or (&H80 <= b2 And b2 <= &HFC)) Then
           'SJIS_C
            sjis = sjis + 2
            i = i + 1
        End If
    Next
    For i = 0 To bLen - 2
        b1 = bytes(i)
        b2 = bytes(i + 1)
        If ((&HA1 <= b1 And b1 <= &HFE) And _
            (&HA1 <= b2 And b2 <= &HFE)) Or _
            (b1 = &H8E And (&HA1 <= b2 And b2 <= &HDF)) Then
            'EUC_C
            'EUC_KANA
            euc = euc + 2
            i = i + 1
        ElseIf i < bLen - 2 Then
            b3 = bytes(i + 2)
            If b1 = &H8F And (&HA1 <= b2 And b2 <= &HFE) And _
                (&HA1 <= b3 And b3 <= &HFE) Then
                'EUC_0212
                euc = euc + 3
                i = i + 2
            End If
        End If
    Next
    For i = 0 To bLen - 2
        b1 = bytes(i)
        b2 = bytes(i + 1)
        If (&HC0 <= b1 And b1 <= &HDF) And _
            (&H80 <= b2 And b2 <= &HBF) Then
            'UTF8
            utf8 = utf8 + 2
            i = i + 1
        ElseIf i < bLen - 2 Then
            b3 = bytes(i + 2)
            If (&HE0 <= b1 And b1 <= &HEF) And _
                (&H80 <= b2 And b2 <= &HBF) And _
                (&H80 <= b3 And b3 <= &HBF) Then
                'UTF8
                utf8 = utf8 + 3
                i = i + 2
            End If
        End If
    Next
    'M. Takahashi's suggestion
    'utf8 += utf8 / 2;
  
    Select Case True
        Case euc > sjis And euc > utf8
            getCharFromCode = "EUC-JP"
        Case utf8 > euc And utf8 > sjis
            getCharFromCode = "UTF-8N"
        Case sjis > euc And sjis > utf8
            getCharFromCode = "SHIFT-JIS"
        Case Else '判定できない場合
            getCharFromCode = ""
    End Select
End Function

Option Explicit

' Formの呼出
Sub CSVの結合()
    UserForm1.Show
    UserForm1.CommandButton2.Enabled = True
End Sub

Option Explicit

' Fromで指定されたパスからToで指定されたパスを参照する相対パスを作成しPathに返却する。
'        ByVal relative As String 取得結果の相対パス
'        ByVal pathFrom As String 参照元のパス
'        ByVal attribFrom As Long Fromで指定したパスのファイル属性。特に、Fromがファイルを表すか、ディレクトリを表すかを判定するために使用される
'        ByVal pathTo As String 参照先のパス
'        ByVal attribTo As Long Toで指定したパスのファイル属性。特に、Toがファイルを表すか、ディレクトリを表すかを判定するために使用される
Private Declare PtrSafe Function PathRelativePathTo _
    Lib "Shlwapi.dll" _
    Alias "PathRelativePathToA" ( _
        ByVal relative As String, _
        ByVal pathFrom As String, _
        ByVal attribFrom As Long, _
        ByVal pathTo As String, _
        ByVal attribTo As Long) _
    As Long

Private Const MAX_PATH As Integer = 260
Private Const FILE_ATTRIBUTE_DIRECTORY As Integer = 16

' 相対パスを取得
Public Function GetRelativePath(ByVal pathFrom As String, ByVal path As String) As String
    Dim length As Integer
    Dim relative As String
    relative = String(MAX_PATH, Chr(0))
    If PathRelativePathTo(relative, pathFrom, FILE_ATTRIBUTE_DIRECTORY, path, 0) Then
        length = InStr(relative, Chr(0)) - 1
        GetRelativePath = Left(relative, length)
    Else
        GetRelativePath = path
    End If
End Function

Option Explicit

' https://excel-ubara.com/excelvba4/EXCEL271.html　を参考に作成
' 遅い文字列結合を最速処理する方法について
' 文字列の結合を高速化している

Private iBuf As Long ' 実際に格納している文字列の長さ
Private sBuf As String ' 文字列の実体
Private sBufLen As Long ' 確保している文字列の実体の長さ
Private Const initLen As Integer = 1024 ' 初期に確保する文字列の実体の長さ

' 文字列を初期化
Private Sub Class_Initialize()
    sBuf = String$(initLen, vbNullChar)
    sBufLen = Len(sBuf)
    iBuf = 0
End Sub

' 文字列の末尾に文字列を追加
Public Sub Append(ByRef sValue As String)
    Dim lens As Long
    lens = Len(sValue)
    If iBuf + lens > sBufLen Then ' 確保した実体の長さを超える場合は拡大する
        sBufLen = sBufLen * 2
        sBuf = sBuf & String$(sBufLen + lens, vbNullChar)
    End If
    Mid(sBuf, iBuf + 1) = sValue
    iBuf = iBuf + lens
End Sub

' 文字列の末尾に文字列を１文字だけ追加（今回のCSV処理では多用するので）
Public Sub Append1(ByRef sValue As String)
    Dim iBuf_1 As Long
    iBuf_1 = iBuf + 1
    If iBuf_1 > sBufLen Then ' 確保した実体の長さを超える場合は拡大する
        sBufLen = sBufLen * 2
        sBuf = sBuf & String$(sBufLen + 1, vbNullChar)
    End If
    Mid(sBuf, iBuf_1) = sValue
    iBuf = iBuf_1
End Sub

' 文字列として切り出す
Public Function ToString() As String
    ToString = Left$(sBuf, iBuf)
End Function

' 文字の実体はそのままに長さを0とする
Public Sub Clear()
    iBuf = 0
End Sub

' 長さを返す
Public Function length() As Long
    length = iBuf
End Function