'Microsoft Scripting Runtimeにチェックを入れる→FileSystemObjectを使用する為
'Microsoft ActiveX Data Objects x.x にチェックを入れる→ADODB.Streamを使用する為
Public Sub CSVファイルをdataシートへ全て書き出し_Tanaka()
    '以下の改良を行った by Tanaka
    '  [1]フォルダをユーザーに選択させる
    '  [2]選択したフォルダの中にCSVファイル以外が含まれる場合は実行中止

    Dim fs As New Scripting.FileSystemObject
    Dim files As Scripting.files
    Dim file As Scripting.file
    Dim strLine As String
    Dim sData As String
    Dim SPcsvData As Variant
'    Dim path As String
    Dim fName As String
    Dim cnt As Long
    Dim ar() As Variant
    Dim c As Long
    'utf-8(BOM有) csvファイルの文字化け対策用
    Dim ado_stream As New ADODB.Stream
    
    MsgBox "CSVファイルが保存されているフォルダを選択してください。"
    '[1]FileDialogオブジェクトを使う方法
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Set files = fs.GetFolder(.SelectedItems(1)).files
        Else
            Exit Sub
        End If
    End With
    '[2]ファイル拡張子でcsvを判定
    For Each file In files
        If LCase(fs.GetExtensionName(file)) <> "csv" Then
            MsgBox "CSVファイル以外のファイルが含まれるため実行できません。"
            Exit Sub
        End If
    Next
    'CSVファイルは、BusinessReportフォルダの中へ保存しておく
    'path = ThisWorkbook.path & "\BusinessReport"
    'Set files = fs.GetFolder(path).files

    cnt = 0 '配列で使用するカウント用
    For Each file In files
        'utf-8 csv文字化け対策
        With ado_stream
            .Charset = "utf-8"
            .LineSeparator = 10 '改行されなかったので設定変更
            .Open
            .LoadFromFile (file)
        
            fName = Right(fs.GetBaseName(file), 8) 'ファイル名の日付部分のみを取得、この先の配列0に入れる
            
             ado_stream.SkipLine '1行目(タイトル行)は読まない
            'CSVファイルを2行目から1行づつ読み、ar配列へ格納
            Do Until .EOS
                strLine = .ReadText(adReadLine) '一行読む
                sData = replaceColon(strLine) '\3,000のカンマも区切りと判断される為、区切りのカンマだけ：に置換
                SPcsvData = Split(sData, ":")
                
                ReDim Preserve ar(12, cnt)
                ar(0, cnt) = fName 'ファイル名から取得した日付を配列に格納
                
                'CSVの中の12項目も配列に格納
                For c = LBound(SPcsvData) To UBound(SPcsvData)
                    ReDim Preserve ar(12, cnt)
                    ar(c + 1, cnt) = Mid(SPcsvData(c), 2, Len(SPcsvData(c)) - 2) 'データが""で囲われているので除去
                Next
                           
                cnt = cnt + 1
            Loop
        
            .Close 'ファイルを閉じる
        End With
    Next
    
    '何かデータが入っていた時の為に、一度セルのデータを消去
    Worksheets("data").Range("A1").CurrentRegion.ClearContents
    
    '読み込んだCSVファイルのデータを一気に書き出し
    Worksheets("data").Range("A1").Resize(UBound(ar, 2) + 1, UBound(ar, 1) + 1).Value = _
    Application.WorksheetFunction.Transpose(ar) 'Excel関数で行列入替
    
    Set file = Nothing
    Set files = Nothing
    Set fs = Nothing
End Sub