概要

CSVファイルをExcelに読み込ませて、任意の列のセル書式を「文字列」に変換するVBA。
また、任意の列をグループごとにデータ分割し、それぞれのデータをシート別に出力する。
使い方

下のようなExcelシートを用意します。
各ボタンにマクロを登録します。
上から順に。。。
'CSV分割＆整形ツール.xlsm'!'readCsv False'
'CSV分割＆整形ツール.xlsm'!'deleteSheet False,True'
'CSV分割＆整形ツール.xlsm'!'deleteSheet False,False'
'CSV分割＆整形ツール.xlsm'!'divideCsv False'
'CSV分割＆整形ツール.xlsm'!'divideCsv True'
'CSV分割＆整形ツール.xlsm'!exportFiles
マニュアル、設定マスタシートも作成します。
マニュアルシートは今回は白紙とします。
設定マスタシートは↓のように作ってください。
A列の「文字列出力項目名」は、セル書式を文字列にする列名を記入。
B列の「分割項目名」は、グループ単位で分割したい列名を記入。
C列の「分割パラメータリスト」は、B列の「分割項目名」で指定した列のうち、分割対象のパラメータを記入。
記入されたパラメータに合致するグループのみ分割して、新規シートに転記します。
動作後イメージ

5.CSV読込＆データ分割ボタン押下後
「シート一覧」に生成されたシートへのリンクが作成されます。
設定マスタの「文字列出力項目名」に記入されていた「項目5」列が文字列として出力されています。
設定マスタの「分割パラメータリスト」に記入されていた各パラメータに合致するデータのみ、データ分割＆シートに転記されています。
ソース

CSV分割＆整形ツール.xlsm
'=======================================================================
'
' File Name       : CSV分割＆整形ツール.xlsm
' Creation Date   : 2019/04/03
'
' Copyright (c) 2019 irohamaru. All rights reserved.
'
' This source code or any portion thereof must not be
' reproduced or used in any manner whatsoever.
'
'=======================================================================

Option Private Module

Dim openFilePath As String                       '読込CSVファイルパス
Dim headerList As Variant                        '読込CSVヘッダー
Dim readCsvResult As Boolean                     '0: エラー（デフォルト）, 1:正常終了, 2:既に読込済
Const adOpenKeyset = 1
Const adLockReadOnly = 1
Const MAINSHEETNAME As String = "メイン"         'メインシート名
Const MANUALSHEETNAME As String = "マニュアル"   'マニュアルシート名
Const SETSHEETNAME As String = "設定マスタ"      '設定マスタシート名
Const CONVLISTCOL As String = "A"                '文字列出力項目名_列
Const DIVLISTCOL As String = "B"                 '分割項目名_列
Const DIVPARAMLISTCOL As String = "C"            '分割項目パラメータ_列
Const SHEETLISTCOL As String = "H"               'シート一覧列
Const HEADERROW As Integer = 2                   'シート一覧ヘッダーセル行番号
Const PREFIX As String = "【Excel変換】"         '出力ファイル接頭語
Const CSVEXT As String = ".csv"                  'CSV拡張子
Const THRESHOLD As Integer = 100                 '分割数アラート閾値

' CSVファイル読込
Sub readCsv(callFromDivideCsv)
    On Error Resume Next
    
    On Error GoTo readCsvErr1
        
    readCsvResult = 0
    
    Dim mainSheet As Worksheet
    Set mainSheet = Worksheets(MAINSHEETNAME)

    openFilePath = selectFile

    ' CSVの項目数
    Dim columnCount As Integer: columnCount = 0
    
    If openFilePath = "False" Then
        MsgBox "読み込むファイルを選択してください。" & vbCrLf & _
                    "処理を終了します。", vbExclamation
        GoTo readCsvErr1
    Else
        ' CSVの項目一覧、項目数を取得
        Dim buf As String
        Open openFilePath For Input As #1
            Do Until EOF(1)
                Line Input #1, buf
                headerList = Split(buf, ",")
                columnCount = UBound(headerList)
                Exit Do
            Loop
        Close #1
    End If
    
    Dim fileName As String
    Dim csvFileCount As Integer: csvFileCount = 0
    ' シート名は31文字以内
    fileName = makeBaseCsvSheetName()
    For Each sh In Worksheets
        If InStr(sh.Name, CSVEXT) > 0 Then
            csvFileCount = csvFileCount + 1
        End If
        If sh.Name = fileName Then
            If callFromDivideCsv = False Then
                MsgBox "同名のファイルが既に読み込まれています。" & vbCrLf & _
                            "「シートを全削除」ボタンをクリックし、" & _
                                "シート削除後再度実行してください。", vbExclamation
            End If
            readCsvResult = 2
            GoTo readCsvErr1
        End If
    Next
    If csvFileCount >= 1 Then
        MsgBox "複数のCSVファイルが読み込まれています。" & vbCrLf & _
                    "読み込むCSVファイルは1ファイルにしてください。" & vbCrLf & _
                        "処理を終了します。", vbExclamation
        GoTo readCsvErr1
    End If
    
    On Error GoTo readCsvErr2
    
    ' シート追加
    Dim wsImport As Worksheet
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = makeBaseCsvSheetName()
    
    ' CSVデータ取り込み用シート
    Set wsImport = Worksheets(ActiveSheet.Name)
   
    ' 文字列出力項目名リストを取得
    Dim convList As Variant
    convList = getSettingList(CONVLISTCOL)
    ' Split(Replace(Replace(mainSheet.Range(SETTINGCOL & CONVLISTROW).Value, "　", ""), " ", ""), ",")

    ' 文字列セル書式設定
    Dim i, j As Integer
    Dim dataTypesArray() As Variant
    
    ' 各列の書式設定用配列
    For i = 0 To columnCount
        ReDim Preserve dataTypesArray(i)
        
        For j = 0 To UBound(convList)
            Dim strConv, strHeader As String
            strHeader = CStr(headerList(i))
            strConv = CStr(convList(j))

            If strConv = strHeader Then
                dataTypesArray(i) = xlTextFormat
            End If
        Next
        
        If dataTypesArray(i) = "" Then
            dataTypesArray(i) = xlGeneralFormat
        End If
        
    Next
    
    On Error GoTo readCsvErr3
    
    ' データ読込
    Dim queryTb As QueryTable
    Set queryTb = wsImport.QueryTables.Add(Connection:="TEXT;" & openFilePath, _
                                            Destination:=wsImport.Range("A1")) ' CSV を開く
    With queryTb
        .TextFilePlatform = 932                     ' 文字コードを指定
        .TextFileParseType = xlDelimited            ' 区切り文字の形式
        .TextFileCommaDelimiter = True              ' カンマ区切り
        .RefreshStyle = xlOverwriteCells            ' セルに書き込む方式
        .TextFileColumnDataTypes = dataTypesArray   ' 各列の型を指定
        .AdjustColumnWidth = False                  ' 列幅の自動調整False
        .Refresh                                    ' データを表示
        .Delete                                     ' CSVファイルとの接続を解除
    End With

    If callFromDivideCsv = False Then
        ' シート一覧作成
        Call makeSheetList
        MsgBox "CSVファイルの読込が完了しました。", vbInformation
    End If
    
    readCsvResult = 1
    
readCsvErr3:
    Set queryTb = Nothing
readCsvErr2:
    Set wsImport = Nothing
readCsvErr1:
    Set mainSheet = Nothing

End Sub


' CSVデータを各シートに分割
Sub divideCsv(selectDivParam)
    On Error Resume Next
    
    On Error GoTo divideCsvErr1
    
    Dim mainSheet, tgtSheet, newSheet As Worksheet
    Set mainSheet = Worksheets(MAINSHEETNAME)
    
    ' 分割項目名リストを取得
    Dim divList As Variant
    Dim divColNum As Long
    Dim divColName As String
    divList = getSettingList(DIVLISTCOL)
    ' Split(Replace(Replace(mainSheet.Range(SETTINGCOL & DIVLISTROW).Value, "　", ""), " ", ""), ",")
    
    ' CSVファイル読込
    Call readCsv(True)
    If readCsvResult = 0 Then
        GoTo divideCsvErr1
    Else
        Dim matchCount As Integer: matchCount = 0
        Dim divCount, idx As Integer
        Dim divIdxList() As Variant
        
        If UBound(divList) = -1 Then
            ' シート削除＆リンクをクリア
            ' Call deleteSheet(True, True)
            
            MsgBox "分割項目名が設定されていません。" & vbCrLf & _
                        "処理を終了します。", vbExclamation
            
            GoTo divideCsvErr1
        End If
    
        For divCount = 0 To UBound(divList)
            For idx = 0 To UBound(headerList)
                If divList(divCount) = headerList(idx) Then
                    matchCount = matchCount + 1
                    
                    ' 分割項目名、分割項目列設定
                    divColName = divList(divCount)
                    divColNum = idx + 1
                End If
            Next
        Next
        
        ' 分割対象列存在チェック
        If matchCount = 0 Then
            ' 分割項目名がCSVデータの列に存在しない場合
            ' シート削除＆リンクをクリア
            ' Call deleteSheet(True, True)
            
            MsgBox "分割項目名に設定された列名に合致する列がCSVデータ中に存在しません。" & _
                        vbCrLf & "処理を終了します。", vbExclamation
                        
            GoTo divideCsvErr1
        ElseIf matchCount > 1 Then
            ' 分割項目名がCSVデータの列に複数該当する場合
            ' シート削除＆リンクをクリア
            ' Call deleteSheet(True, True)
            MsgBox "分割項目名に設定された列名がCSVデータ中に複数該当します。" & vbCrLf & _
                    "分割する列は1つのみ合致するように設定してください。" & vbCrLf & _
                    "処理を終了します。", vbExclamation
                        
            GoTo divideCsvErr1
        End If
        
        Set tgtSheet = Worksheets(makeBaseCsvSheetName())
        tgtSheet.Activate
    
    End If
    
    On Error GoTo divideCsvErr2
    
    ' 接続を確立する
    Dim dbCon, dbRs As Object
    Set dbCon = CreateObject("ADODB.Connection")
    Set dbRs = CreateObject("ADODB.Recordset")
    
    dbCon.Provider = "Microsoft.ACE.OLEDB.12.0"
    dbCon.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
    dbCon.Open ThisWorkbook.FullName
    
    ' グループ一覧取得
    Dim strGrpSQL As String
    Dim grpList() As Variant
    Dim cnt As Integer: cnt = 0
    
    If selectDivParam = True Then
        ' 分割パラメータリストを取得
        Dim divParamList As Variant
        divParamList = getSettingList(DIVPARAMLISTCOL)
        
        If UBound(divParamList) = -1 Then
        
            MsgBox "分割パラメータリストが設定されていません。" & vbCrLf & _
                        "処理を終了します。", vbExclamation
            
            ' シート削除＆リンクをクリア
            ' Call deleteSheet(True, True)
        
            GoTo divideCsvErr2
        Else
            
            For Each d In divParamList
                If d <> "" Then
                    ReDim Preserve grpList(cnt)
                    grpList(cnt) = d
                    cnt = cnt + 1
                End If
            Next
            
        End If
        
    Else
        strGrpSQL = ""
        strGrpSQL = strGrpSQL & " SELECT " & "F" & divColNum & " FROM [" & tgtSheet.Name & "$] "
        strGrpSQL = strGrpSQL & " GROUP BY " & "F" & divColNum
        
        dbRs.Open strGrpSQL, dbCon, adOpenKeyset, adLockReadOnly
    
        Do Until dbRs.EOF
           If divColName = dbRs.Fields(0).Value Then GoTo Continue
           ReDim Preserve grpList(cnt)
           ' シート名は31文字以内
           grpList(cnt) = Left(dbRs.Fields(0).Value, 31)
           cnt = cnt + 1
Continue:
           dbRs.MoveNext
        Loop
    
        dbRs.Close
    
    End If
    
    If UBound(grpList) >= THRESHOLD Then
        Dim rs As Integer
        rs = MsgBox("データ分割により、シートを" & UBound(grpList) & "作成します。" & vbCrLf & _
                "分割パラメータを指定することを推奨します。" & vbCrLf & _
                "処理を続行しますか？", vbYesNo + vbExclamation, "確認")
                
        ' 続行しない場合は処理終了
        If rs = vbNo Then
            GoTo divideCsvErr2
        End If
        
    End If
    
    Dim strSQL As String
    
    ' グループ分シート生成＆データ貼り付け
    Dim i As Integer
    For i = 0 To UBound(grpList)
        Dim grpListStr As String
        grpListStr = CStr(grpList(i))
        
        strSQL = ""
        strSQL = strSQL & " SELECT * FROM [" & tgtSheet.Name & "$] "
        strSQL = strSQL & " WHERE " & "F" & divColNum & " = '" & grpListStr & "'"
        dbRs.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly
        
        ' シート追加
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = grpListStr
        Set newSheet = Worksheets(grpListStr)
        ' ヘッダー追加
        Dim columnCount As Integer
        columnCount = UBound(headerList)
        Dim j As Integer
        For j = 0 To columnCount
            newSheet.Cells(1, j + 1) = headerList(j)
        Next
        newSheet.Range("A2").CopyFromRecordset dbRs
        dbRs.Close
        
        ' 列幅自動調整
        ' newSheet.Range(Columns(1), Columns(columnCount)).EntireColumn.AutoFit
        
    Next
    
    ' シート一覧作成
    Call makeSheetList
    
    ' メインシートを選択
    mainSheet.Activate
    mainSheet.Range("A1").Select
    
    MsgBox "CSVデータを各シートに分割しました。" & vbCrLf & _
                "処理を終了します。", vbInformation
    
divideCsvErr2:
    Set dbRs = Nothing
    dbCon.Close
    Set dbCon = Nothing
divideCsvErr1:
    Set newSheet = Nothing
    Set tgtSheet = Nothing
    Set mainSheet = Nothing

End Sub


' シート削除
Sub deleteSheet(callFromDivideCsv, deleteBaseCsv)
    On Error Resume Next
    
    On Error GoTo deleteSheetErr

    Dim mainSheet As Worksheet
    Set mainSheet = Worksheets(MAINSHEETNAME)

    Application.DisplayAlerts = False
    
    ' リンクをクリア
    Call deleteLink(mainSheet, deleteBaseCsv)
    
    ' シート削除
    For Each sh In Worksheets
        If sh.Name <> MAINSHEETNAME And _
            sh.Name <> MANUALSHEETNAME And sh.Name <> SETSHEETNAME Then
            If deleteBaseCsv = True Then
                sh.Delete
            Else
                If InStr(sh.Name, CSVEXT) = 0 Then
                    sh.Delete
                End If
            End If
        End If
    Next
    
    Application.DisplayAlerts = True
    
    If callFromDivideCsv = False Then
        MsgBox "メインシート以外を削除しました。" & vbCrLf & _
                    "処理を終了します。", vbInformation
    End If
    
deleteSheetErr:
    Set mainSheet = Nothing

End Sub


' ファイル出力
Sub exportFiles()
    ' メイン、マニュアル、設定マスタシート以外がない場合終了
    If Worksheets.Count = 3 Then
        MsgBox "出力対象のシートがないため、処理を終了します。", vbExclamation
        Exit Sub
    End If

    ' フォルダ存在チェック＆作成
    Dim folderPath As String
    Dim createFolder As Boolean
    For Each sh In Worksheets
        If InStr(sh.Name, CSVEXT) > 0 Then
            folderPath = ThisWorkbook.Path & "\" & PREFIX & Replace(sh.Name, CSVEXT, "")
            If Dir(folderPath, vbDirectory) = "" Then
                ' 保存先フォルダ作成
                MkDir folderPath
                createFolder = True
            Else
                ' 同名のフォルダが既に存在している場合終了
                MsgBox folderPath & vbCrLf & _
                        "が既に存在するため、処理を終了します。", vbExclamation
                Exit Sub
            End If
        End If
    Next
    If createFolder = False Then
        MsgBox "分割元のCSVファイルの内容が記載されたシートが見つかりませんでした。" & vbCrLf & _
                "処理を終了します。", vbExclamation
        Exit Sub
    End If
    
    For Each sh In Worksheets
        Dim fileName As String
        If sh.Name <> MAINSHEETNAME And _
            sh.Name <> MANUALSHEETNAME And sh.Name <> SETSHEETNAME Then
            If InStr(sh.Name, CSVEXT) > 0 Then
                fileName = PREFIX & Replace(sh.Name, CSVEXT, "")
            Else
                fileName = sh.Name
            End If
            sh.Copy
            ActiveWorkbook.SaveAs folderPath & "\" & fileName
            ActiveWorkbook.Close
        End If
    Next
    
    MsgBox folderPath & vbCrLf & _
                "にファイルを出力しました。" & vbCrLf & _
                "処理を終了します。", vbInformation
    
End Sub


' 読込ファイル選択
Function selectFile()
    '読み込むファイル
    selectFile = Application.GetOpenFilename("CSVファイル,*.csv")
    
End Function


' 設定マスタリストを取得
Function getSettingList(col)
    Dim setMstSheet As Worksheet
    Set setMstSheet = Worksheets(SETSHEETNAME)
    
    Dim returnList As Variant
    returnList = Array()
    
    With setMstSheet
        If .Range(col & 2).Value <> "" Then
            Dim maxRow, i As Integer
            maxRow = .Range(col & 1).End(xlDown).Row
            
            For i = 2 To maxRow
                ReDim Preserve returnList(i - 2)
                returnList(i - 2) = .Range(col & i).Value
            Next
        End If
    End With
    
    Set setMstSheet = Nothing
    
    getSettingList = returnList
    
End Function


' 分割元CSVファイル設定
Function makeBaseCsvSheetName()
    If InStr(Left(Dir(openFilePath), 31), CSVEXT) > 1 Then
        makeBaseCsvSheetName = Left(Dir(openFilePath), 31)
    Else
        makeBaseCsvSheetName = Left(Dir(openFilePath), 27) & CSVEXT
    End If
End Function


' シートリストを作成
Private Sub makeSheetList()
    On Error Resume Next

    On Error GoTo makeSheetListErr
    
    Dim mainSheet As Worksheet
    Set mainSheet = Worksheets(MAINSHEETNAME)
    
    ' リンクをクリア
    Call deleteLink(mainSheet, True)
    
    ' リンクを作成
    Dim j, k As Integer: k = 1
    For j = 1 To Worksheets.Count
        If Worksheets(j).Name <> MAINSHEETNAME And _
                Worksheets(j).Name <> MANUALSHEETNAME And _
                    Worksheets(j).Name <> SETSHEETNAME Then
            mainSheet.Hyperlinks.Add Anchor:=mainSheet.Range(SHEETLISTCOL & HEADERROW + k), _
            Address:="", _
            SubAddress:="'" & Worksheets(j).Name & "'" & "!A1", _
            TextToDisplay:=Worksheets(j).Name
            k = k + 1
        End If
    Next

    ' 左寄せ
    mainSheet.Range(SHEETLISTCOL & ":" & SHEETLISTCOL).HorizontalAlignment = xlLeft
    ' 列幅自動調整
    mainSheet.Columns(SHEETLISTCOL & ":" & SHEETLISTCOL).AutoFit
    
makeSheetListErr:
    Set mainSheet = Nothing

End Sub


' リンクをクリア
Private Sub deleteLink(sh, deleteBaseCsv)
    Dim maxRow As Integer: maxRow = HEADERROW
    
    ' シート一覧に1つ以上記入がある場合のみ処理
    If sh.Range(SHEETLISTCOL & HEADERROW + 1).Value <> "" Then
        maxRow = sh.Range(SHEETLISTCOL & HEADERROW).End(xlDown).Row

        Dim linkStr As String
        Dim i As Integer
        For i = HEADERROW + 1 To maxRow
            linkStr = sh.Range(SHEETLISTCOL & i).Value
            If deleteBaseCsv = False And InStr(linkStr, CSVEXT) > 0 Then
                ' 分割元CSVデータシートを削除しない場合、リンクも削除しない
            Else
                sh.Range(SHEETLISTCOL & i).Value = ""
            End If
        Next
        
        ' 列幅自動調整
        sh.Columns(SHEETLISTCOL & ":" & SHEETLISTCOL).AutoFit
        
    End If
    
    ' セル選択
    sh.Activate
    sh.Range("A1").Select

End Sub