拡張CSVに対応した CSV インポート

CSV ファイルを読み込むとき VB.NET であれば TextFieldParser というクラスで簡単に行えるのですが Excel 2003 の VBA には該当クラスは存在しません。自分で CSV を読み込む際に問題になるのが値として含まれるカンマ「,」です。Microsoft では以下のようにダブルクォーテーションで囲うことで、それを表現しています（拡張CSV）。

1,"HERE,THERE AND EVERYWHERE",The Beatles
2,"Walk, Don't Run!",Johnny Smith
3,TARKUS,"Emerson, Lake & Palmer"

このようにすべての項目にダブルクォーテーションがつくとは限らないし、出現位置も同じとは限らないのが特徴です。また、ダブルクォーテーションそのものを値として含む場合には「""」という形で表わすので、これにも考慮しないといけません。

こうした CSV を読み込むために、正規表現と文字列関数を合わせて作った処理が以下。適当なボタンにマクロ登録して使う事を想定しています。

' CSVインポートボタンクリック
Sub ImportCsvClick()
    Const FORM_TITLE = "CSVファイル読み込み処理"
    Const FORM_FILTER = "CSVファイル (*.csv),*.csv"
    Dim xlApp As Application            ' Application オブジェクト
    Dim fIndex As Integer               ' FreeFile 値
    Dim strFile As String               ' 入力されるファイル名
    Dim recordArray() As Variant        ' 読み込んだレコードの配列
    Dim rowIndex As Long                ' CSV の項目インデックス
    Dim lineIndex As Long               ' レコード件数のインデックス
    Dim strInput As String              ' 読み込まれるレコード行
    Dim startIndex As Long              ' 行検索開始位置のインデックス
    Dim destIndex As Long               ' 同、終了位置のインデックス
    Dim objRegex, objMatches As Object  ' 正規表現クラスのオブジェクト
    Dim strPattern As String            ' ダブルクォートの正規表現パターン

    ' Application オブジェクト取得
    Set xlApp = Application
    ' フォームからファイルを受け取る
    strFile = xlApp.GetOpenFilename(FileFilter:=FORM_FILTER, Title:=FORM_TITLE)
    ' キャンセルされた場合処理を終了
    If StrConv(strFile, vbUpperCase) = "FALSE" Then
        Exit Sub
    End If
    
    ' CSV データが入力されるシートを選択
    Worksheets("シート名指定").Activate
    
    ' FreeFile 形式で入力を行う
    fIndex = FreeFile
    ' 指定ファイルを開く
    Open strFile For Input As #fIndex
    
    ' 入力行の初期化
    lineIndex = 1
    ' 正規表現のセット
    Set objRegex = CreateObject("VBScript.RegExp")
    strPattern = "^"".*?""[,$]"
    With objRegex
        .Pattern = strPattern
        .ignorecase = True
        .Global = True
    End With
    
    ' ファイルの末尾まで繰り返す
    Do Until EOF(fIndex)
        ' 行単位にレコードを読み込む
        Line Input #fIndex, strInput

        ' 値の初期化
        startIndex = 1
        rowIndex = 0
        ReDim recordArray(rowIndex)
        
        Do While startIndex <= Len(strInput)
            ' カンマで分ける前に、ダブルクォートに挟まれた部分を分割できないか試す
            ' 現在位置からの部分文字列を検索するのがポイント
            Set objMatches = objRegex.Execute(Mid(strInput, startIndex))
            ' マッチする？
            If objMatches.Count > 0 Then
                ' 最初にマッチした部分のデータから、カラムの終了位置を探す
                destIndex = startIndex + Len(objMatches(0).Value) - 1
            Else
                ' マッチしなかったなら、単なるカンマ探し
                destIndex = InStr(startIndex, strInput, ",", vbTextCompare)
                ' カンマが見つからないなら検索終了
                If destIndex < startIndex Then
                    destIndex = Len(strInput) + 1
                End If
            End If
            ' 配列サイズを変更し、値を末尾に追加
            ReDim Preserve recordArray(rowIndex)
            recordArray(rowIndex) = Trim(Mid(strInput, startIndex, destIndex - startIndex))
            
            ' ダブルクォーテーションが存在するなら除去
            If ((Left(recordArray(rowIndex), 1) = """") And (Right(recordArray(rowIndex), 1) = """")) Then
                recordArray(rowIndex) = Trim(Mid(recordArray(rowIndex), 2, Len(recordArray(rowIndex)) - 2))
            End If
            ' 途中に入った二重のダブルクォートにも見栄え上の処理を施す
            recordArray(rowIndex) = Replace(recordArray(rowIndex), """""", """")
            
            ' 検索開始位置の更新
            startIndex = destIndex + 1
            rowIndex = rowIndex + 1
        Loop

        ' レコード内容をシートに入力
        If rowIndex >= 1 Then
            Range(Cells(lineIndex, 1), Cells(lineIndex, rowIndex)).Value = recordArray
        End If
        ' 次の行へ
        lineIndex = lineIndex + 1
    Loop

    ' ファイルを閉じる
    Close #fIndex
End Sub

と、多少強引ですが正規表現を使った分、まだ理解しやすい挙動になったのではないかと。動作も確認したので問題ないとは思いますが、何か気がついた点があれば教えて頂ければ幸いです。