Excel の QueryTable で CSV ファイルを取り込む VBScript

たとえば、

文書ID,組織コード,クラス
901234567890987654321,0012,3-5
909876543210123456789,0013,3-7

のような CSV ファイルを Excel で直接開くと、

文書ID	組織コード	クラス
9.01235E+20	12	3月5日
9.09877E+20	13	3月7日

のように勝手に変換されて表示されてしまう。かといって、いちいちPowerQueryで開くのも面倒だ。
そこで、Excel のQueryTableで CSV データを文字列として取り込む VBScript ファイルを作ってみる。

CSVをExcelで開く.vbs

'==============================================================
' Excelが余計なことをしないように、CSVデータを文字列として開く
'==============================================================
' このスクリプトファイルを SendToフォルダに入れて、
' 選択したCSVファイルを右クリックでこのスクリプトに［送る］か、もしくは、
' 選択したCSVファイルをこのスクリプトファイルに直接ドラッグする
' 複数ファイル選択可（一つのブックに選択ファイル分のシートが作成される）

Option Explicit

Dim args, fso, xlApp, i, sh, cntAry

Set args  = WScript.Arguments    '// 選択したCSVファイルのコレクションオブジェクト
Set fso   = CreateObject("Scripting.FileSystemObject")
Set xlApp = CreateObject("Excel.Application")

With xlApp
    .Visible = True

    With .Workbooks.Add
        .Application.WindowState = 3                        '// ウィンドウを最大化する
        CreateObject("WScript.Shell").AppActivate(.Name)    '// 開いたエクセルを最前面にする
        
        For i = 0 To args.Count-1
            Set sh = .Worksheets.Add

            cntAry = XlQueryTable(args(i), "Shift-JIS", sh) '// 取り込み実行

            With sh
                .Name = Left(RepairName(fso.GetFileName(args(i))), 30)  '// シート名31文字制限
                .Range(.Cells(1, 1), .Cells(1, cntAry(1))).Interior.Color = RGB(210, 210, 210)

                '// 先頭行固定
                .Rows(2).Select
                xlApp.ActiveWindow.FreezePanes = True
                .Range("A2").Select  
            End With

            Set sh = Nothing
        Next
    End With
End With

'// 文字コードが char_code のCSVファイル（csv_path）を QueryTable で読み込み
'// 行数と列数の値を配列で返す

Function XlQueryTable(Byval csv_path, Byval char_code, work_sheet)

    Dim typeArry()	'// データ型の配列
    Dim i			'// ループカウンタ
    Dim charCodeN	'// 文字コード定数
    Dim qt			'// クエリテーブル
    Dim cntAry		'// 行数はcntAry(0)、列数はcntAry(1)

	cntAry = LinesCount(csv_path)

    ReDim typeArry(cntAry(1))
    For i = 0 To cntAry(1)
        typeArry(i) = 2
    Next

    If char_code = "Shift-JIS" Then charCodeN = 932
    If char_code = "UTF-8"     Then charCodeN = 65001

    With work_sheet
        With .QueryTables.Add("TEXT;" & csv_path, .Range("A1"))
            .AdjustColumnWidth = True
            .TextFilePlatform = charCodeN
            .TextFileStartRow = 1
            .TextFileTextQualifier = 1
            .TextFileCommaDelimiter = True
            .TextFileColumnDataTypes = Array(typeArry)
            .Refresh
            .Delete
        End With

        For Each qt In .QueryTables
            qt.Delete
        Next
    End With

    XlQueryTable = cntAry

End Function

'// 読み込んだCSVファイルの行数と列数を配列で返す

Function LinesCount(ByVal csv_path)

    Dim lineAry, cntAry(1)

    With CreateObject("Scripting.FileSystemObject").OpenTextFile(csv_path, 1)
    	lineAry = Split(.ReadAll, vbCrLf)
        .Close
    End With

    cntAry(0) = UBound(lineAry)
    cntAry(1) = UBound(Split(lineAry(1), ",")) + 1

    LinesCount = cntAry

End Function

'// シート名に使用できない文字を修正する

Function RepairName(sh_name)

    Dim chrAry
    Dim newName

    chrAry = Array(":", "￥", "\", "/", "?", "*")

    newName = Left(sh_name, 31)
    newName = Replace(newName, "[", "〔", 1, -1, 1)
    newName = Replace(newName, "]", "〕", 1, -1, 1)

    For i = LBound(chrAry) To Ubound(chrAry)
        newName = Replace(newName, chrAry(i), "^", 1, -1, 1)
    Next

    RepairName = newName

End Function