Excel VBAでCSVファイルを自在に読み込む：ゼロ落ちなし、数値・文字列OK

何がしたいのか

CSVファイルをエクセル形式にインポートする際、次のような要件を満たしたいです。

• コードなど文字列の項目はゼロ落ちしないように文字列で取り込みたい
• 数値や金額の項目は集計しやすいように数値や金額で取り込みたい
• 上記の要件を、エクセルの書式設定と同じレベルで、簡単に自由にできるようにしたい

CSVファイルを貼り付けるフォーマットのエクセル形式のファイルに、あらかじめ書式設定で文字列や数値・金額などの設定をしておくことで、データ型が設定されるようにします。
この方法はネットで検索できなかったため、作成したコードを共有しますので、参考にしてください。

動作確認済みの環境

以下の環境で動作を確認しています。

• Windows11 Microsoft Excel 2016(32bit)
• Windows10 Microsfot365 Excel 2404(32bit)

2024年現在サポートのあるエクセルであれば動作するはずです。

対応方針

いったんすべての項目を文字列としてエクセルの機能で読み込み、それを二次元配列へ格納。書式の設定されたセル範囲へ二次元配列から転記することで、書式にあったデータ型へ変換される挙動を利用します。

動作イメージ

CSVファイルを用意

下のようなファイルを読み込みたいとします。

test/in.csv

id,amount,percentage
001,004998339,0.125
002,000499833,0.252
003,007622957,0.871
004,008377090,0.084

フォーマットファイルを用意

必要に応じて、各項目に文字列や金額などの書式を設定しています。
2行目は設定した書式がわかるように入力したダミーデータです。

• test/fmt.xlsx
  

VBAを実行

CSV2XLSX "test\in.csv", "test\fmt.xlsx", "test\out.xlsx", "Sheet1!$A$2"

出力を確認

フォーマットに設定した形式で読み込まれます。

• test/out.xlsx
  

VBAコード

以下のコードを標準モジュールに貼り付け、main_Csv2Xlsx()内のファイル名等は適宜変更してください。
このバージョンではエラー処理をあまり書いていないので、ファイルが見つからないと何も言わずに終了します。適宜処理を追加してください。

Option Explicit

Sub main_Csv2Xlsx()
'メイン処理

'CSVファイルを読み込み、エクセルフォーマットに指定した書式に合わせたデータを貼り付ける
    CSV2XLSX "test\in.csv", "test\fmt.xlsx", "test\out.xlsx", "Sheet1!$A$2"
    
End Sub

Function CSV2XLSX(strCSVFullname As String, strFMTFullname As String, strOutputFullname As String, strPasteRange As String, Optional lInOffset As Long = 1)
    
    'ファイルチェック・ファイル名取得（CSVファイルはワイルドカード使用可能）
    If strCSVFullname = "" Or strFMTFullname = "" Then Exit Function
    
    If Not getFSO.FileExists(strFMTFullname) Then Debug.Print "▲ファイルが見つかりません:" & strFMTFullname: Exit Function
    strFMTFullname = strFMTFullname
    
    
    'ファイル読み込み
    Dim wsCSV As Worksheet
    Set wsCSV = OpenCSVAsString(ConfirmPath(strCSVFullname))
    If wsCSV Is Nothing Then Exit Function
    
    Dim wbFMT As Workbook
    Set wbFMT = Workbooks.Open(ConfirmPath(strFMTFullname))
    If wbFMT Is Nothing Then Exit Function
    
    Dim rgPaste As Range
    Set rgPaste = strRgToRange(wbFMT, strPasteRange)
    If rgPaste Is Nothing Then Exit Function
    
    '貼付
    Dim mat1 As Variant
    mat1 = wsCSV.Cells(1, 1).CurrentRegion.Offset(lInOffset).value
    rgPaste.Resize(UBound(mat1, 1), UBound(mat1, 2)) = mat1
    wsCSV.Parent.Close False
    
    '保存
    If strOutputFullname <> "" Then
        wbFMT.SaveAs strOutputFullname
        wbFMT.Close False
    End If
End Function

Function strRgToRange(wb1 As Workbook, strRg As String) As Range
'「シート名！セル範囲」の文字列を、Rangeオブジェクトにして返す
    If strRg = "" Then Exit Function
    Set strRgToRange = wb1.Sheets(Left(strRg, InStr(strRg, "!") - 1)).Range(Mid(strRg, InStr(strRg, "!") + 1))
End Function


Function OpenCSVAsString(strCSVFullname As String) As Worksheet
'CSVファイルのパスを受け取り、文字列として展開したシートを返す
    Dim ws As Worksheet
    Dim lColumnCount As Long
    
    If Not getFSO.FileExists(strCSVFullname) Then Exit Function

    '列数取得
    lColumnCount = GetColumnCountFromCSV(strCSVFullname)
        
    '全ての列を文字列で取得する設定にする
    Dim ColumnDataTypes() As Variant
    ReDim ColumnDataTypes(1 To lColumnCount)
    Dim i As Long
    For i = 1 To lColumnCount
        ColumnDataTypes(i) = xlTextFormat
    Next
    
    ' 新しいワークシートを作成
    Set ws = MakeNewWorkbook(1).Sheets(1)

    ' QueryTableを使用してCSVファイルを開く
    With ws.QueryTables.Add(Connection:="TEXT;" & strCSVFullname, Destination:=ws.Range("A1"))
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFilePlatform = 65001  'UTF8
        .TextFileColumnDataTypes = ColumnDataTypes
        .Refresh
    
        .Delete
    End With
    Set OpenCSVAsString = ws
End Function

Function GetColumnCountFromCSV(filePath As String) As Integer
'CSVファイルの項目数（列数）を見出し行のカンマの数で判定して返す
    Dim txtStream As Object
    Dim firstLine As String
    Dim columnCount As Integer

    ' テキストファイルを開く
    Set txtStream = getFSO().OpenTextFile(filePath, 1, False)  ' 1はForReading

    ' 最初の行を読み取る
    If Not txtStream.AtEndOfStream Then
        firstLine = txtStream.ReadLine
    End If

    ' テキストストリームを閉じる
    txtStream.Close

    ' カンマの数を数えて列数を推定
    columnCount = UBound(Split(firstLine, ",")) + 1

    ' 列数を返す
    GetColumnCountFromCSV = columnCount
End Function

今回の記事の本質的な部分は以上です。
以下はヘルパー関数です。

'###################################################################
'# Helper Functions
'###################################################################

Function getFSO() As Object
    Set getFSO = CreateObject("Scripting.FileSystemObject")
End Function

Function addDic(ByRef dic1 As Object, strKey As String, varValue As Variant, Optional blOverWrite As Boolean = True)
'ディクショナリ Dic1 に strKey , varValue を追加する。
'値はオブジェクト型でもオブジェクト以外でも判定するが、その分遅くなる。
'Dic1(strKey)が存在するときは blOverWrite によって上書きするかを指定できる。
'Dic1 がまだ準備されていない時は CreateObject で準備する。

    If dic1 Is Nothing Then Set dic1 = CreateObject("Scripting.Dictionary")
    If dic1.exists(strKey) Then
        If blOverWrite Then
            If VarType(varValue) = vbObject Then
                Set dic1(strKey) = varValue
            Else
                dic1(strKey) = varValue
            End If
        End If
    Else
        dic1.Add strKey, varValue
    End If
    Set addDic = dic1
End Function

Function ConfirmPath(strPath As String) As String
'パス入力を受け取り、フルパスでなければこのファイルのパスからの相対パスとして扱う
    If Mid(strPath, 2, 2) <> ":\" And Left(strPath, 2) <> "\\" Then ConfirmPath = ThisWorkbook.path & "\" & strPath Else ConfirmPath = strPath
    ConfirmPath = DeleteDoubleBackSlash(PathRegularize(ConfirmPath))
End Function

Function DeleteDoubleBackSlash(strPath As String) As String
'パスの中の\\を\に置き換える。ネットワークフォルダに対応するため、先頭の文字はそのまま使う。
    DeleteDoubleBackSlash = Left(strPath, 1) & Replace(Mid(strPath, 2), "\\", "\")
End Function

Function PathRegularize(strPath As String) As String
'\..\ や \.\ を正規化する
    Dim reg As Object
    Set reg = CreateObject("VBScript.RegExp")   'オブジェクト作成
    
    '正規表現オブジェクトの設定
    reg.IgnoreCase = True '大文字と小文字を区別するFalseか、しないTrueか
    reg.Global = False       '文字列全体を検索するTrueか、しないFalseか
    
    '\.\ の置き換え
    reg.Pattern = "\\\.\\"     'パターンを設定します
    Do While reg.Test(strPath)
        strPath = reg.Replace(strPath, "\")
    Loop
    
    '\..\ の置き換え
    reg.Pattern = "[^\\]+\\\.\.\\"
    Do While reg.Test(strPath)
        strPath = reg.Replace(strPath, "")
    Loop
    
    '結果ダイアログを出力
    PathRegularize = strPath
End Function

Function OpenBook(strPath As String, Optional strPw As String, Optional blReadOnly As Boolean = True) As Workbook
'ファイルを開き、そのワークブックを返します。
'既にファイルを開いている場合はそのファイル、同名の別ファイルを開いているときと
'ファイルが存在しない場合はNothingを返します
    
    If Not getFSO.FileExists(strPath) Then
        'ファイルがなければNothingを返す
        Set OpenBook = Nothing
        Exit Function
    Else
        If IsBookOpen2(strPath) = 1 Then
            'ファイルが開かれている
            Set OpenBook = Workbooks(FullName2FileName(strPath))
            Exit Function
        ElseIf IsBookOpen2(strPath) = 2 Then
            '同名の別ファイルが開かれている
            Set OpenBook = Nothing
            Exit Function
        Else
            'ファイルが開かれていないので開く
            Application.DisplayAlerts = False '誰かが開いていて blReadOnly=False の場合のため
            Workbooks.Open strPath, False, blReadOnly, , strPw
            Application.DisplayAlerts = True
            Set OpenBook = Workbooks(FullName2FileName(strPath))
        End If
        
    End If

End Function

Function FullName2FileName(strFullname As String) As String
'フルパスからファイル名を抜き出す
    FullName2FileName = Mid(strFullname, InStrRev(strFullname, "\") + 1)
End Function

Function IsBookOpen2(strBookName As String) As Integer
' 0：ファイルが開かれていない
' 1：ファイルが開かれている
' 2：パスが違う同名のファイルが開かれている
  
  Dim objBook As Workbook
  Dim strPath As String, strFile As String

  IsBookOpen2 = 0
  strBookName = PathRegularize(strBookName)
    
  '\より右を抜き出す
  strPath = Left(strBookName, InStrRev(strBookName, "\"))
  strFile = Mid(strBookName, InStrRev(strBookName, "\") + 1)
  For Each objBook In Workbooks
    If StrComp(objBook.Name, strFile, vbTextCompare) = 0 Then
        If StrComp(DeleteDoubleBackSlash(objBook.path & "\"), DeleteDoubleBackSlash(strPath), vbTextCompare) = 0 Then
            IsBookOpen2 = 1
        Else
            IsBookOpen2 = 2
        End If
        Exit For
    End If
  Next

End Function

Public Function MakeNewWorkbook(Optional iSheetCount As Integer = 1) As Workbook
'新しいブックを指定のシート数で作る
    If iSheetCount < 1 Then iSheetCount = 1
    
    Workbooks.Add
    Set MakeNewWorkbook = ActiveWorkbook
    
    Application.DisplayAlerts = False
    Do While MakeNewWorkbook.Sheets.Count > iSheetCount
        MakeNewWorkbook.Sheets(iSheetCount + 1).Delete
    Loop
    Application.DisplayAlerts = True
    Do While MakeNewWorkbook.Sheets.Count < iSheetCount
        MakeNewWorkbook.Sheets.Add After:=MakeNewWorkbook.Sheets(MakeNewWorkbook.Sheets.Count)
        ActiveSheet.Name = "Sheet" & MakeNewWorkbook.Sheets.Count
    Loop
End Function