データをエクセルにて添付いたしますのでご査収のほどよろしくお願いいたします

Excel シートを CSV でエクスポートする VBScript

xls2csv.vbs

Option Explicit
'--------------------------------------
' Config
'--------------------------------------
const SKIP_COUNT = 0 ' ヘッダ行出力する
'const SKIP_COUNT = 1 ' ヘッダ行出力しない
const FILE_FORMAT = 6 ' CSV (xlCSV)
'const FILE_FORMAT = -4158 ' TSV (xlText/xlCurrentPlatformText)
const FILE_EXT = ".csv"
'const FILE_EXT = ".tsv"

'--------------------------------------
' Globals
'--------------------------------------
dim wshShell
dim winShell
dim fso
dim excel
set wshShell = CreateObject("WScript.Shell")
set winShell = CreateObject("Shell.Application")
set fso = CreateObject("Scripting.FileSystemObject")
set excel = CreateObject("Excel.Application")
excel.Visible = False

'--------------------------------------
' Functions
'--------------------------------------
sub XlsToCvs(xls, csvFolder)
    dim book, sheet, fileName, table
    dim i, c
    set book = excel.WorkBooks.Open(xls,,True) ' Read Only
    for each sheet in book.WorkSheets

        if sheet.Range("A1") = "" then
            ' 左上端のセルから空だったら、非データ用シートとみなしてスキップする
        else
            fileName = csvFolder & "\" & sheet.Name & FILE_EXT
            'WScript.Echo(fileName)
            ' シートを新規bookにコピーする
            sheet.Copy
            ' コピー先がActiveWorkbookになる
            with excel.ActiveWorkbook
                .WorkSheets(1).EnableCalculation = False

                ' 左上端から空行空列で囲まれた領域をデータ範囲とする
                set table = .WorkSheets(1).Range("A1").CurrentRegion

                'clearAround table           ' データ範囲外を消去
                removeGhostCells table      ' 余分な空白行・列を除去
                'keepLocalFormat table       ' 表示書式を維持
                'keepConditionalFormat table ' 条件付き書式を維持
                'escapeSpecialChars table    ' 特殊文字をエスケープ
                'fillEmptyCells table, "\N"      ' 空白セルに値を設定

                'toSqlLiterals table         ' SQL のリテラル表現

                ' ヘッダ行をSKIP_COUNT行分削除
                if SKIP_COUNT > 0 then
                    .WorkSheets(1).Cells.Rows("1:" & SKIP_COUNT).EntireRow.Delete
                end if

                ' ファイル形式を指定して１シートを保存
                excel.DisplayAlerts = False
                .SaveAs fileName, FILE_FORMAT
                .Close
                excel.DisplayAlerts = True
            end with
            'forceQuote(fileName)                ' 全てのフィールドを引用符付け
            'setLineTerminator fileName, vbLf    ' レコード区切りを変更
            'convertToUTF8(fileName)             ' BOMなしUTF-8に変換
        end if
    next
    book.Close False 
end sub

sub clearAround(rng)
    dim data
    data = rng.Value ' 値を配列に退避
    rng.parent.Cells.ClearContents ' 書式を残しつつ全セル消去
    rng.Value = data
end sub

sub removeGhostCells(rng)
    const xlCellTypeLastCell = 11
    dim corner, margin, dr, dc
    set corner = rng.cells(rng.Rows.Count, rng.Columns.Count)
    set margin = rng.SpecialCells(xlCellTypeLastCell)
    dr = margin.Row - corner.Row
    dc = margin.Column - corner.Column
    if 0 < dr then
        corner.Offset(1,0).Resize(dr).EntireRow.Delete
    end if
    if 0 < dc then
        corner.Offset(0,1).Resize(,dc).EntireColumn.Delete
    end if
end sub

sub keepLocalFormat(rng)
    dim col, c, numberCells
    for each col in rng.Columns
        set numberCells = collectNumberCells(col)
        if not numberCells is Nothing then
            set c = numberCells.Rows(1)
            if c.NumberFormat <> "General" and c.NumberFormat <> c.NumberFormatLocal then
                c.EntireColumn.NumberFormat = c.NumberFormatLocal
            end if
        end if
    next
end sub

sub keepConditionalFormat(rng)
    const xlExpression = 2
    dim fc, addrs, c
    addrs = ""
    for each fc in rng.FormatConditions
        ' if fc.NumberFormat <> "" then ' なぜかエラーになる
            addrs = addrs & fc.AppliesTo.Address & ","
        ' end if
    next
    if addrs = "" then exit sub
    addrs = Left(addrs, Len(addrs)-1)
    for each c in rng.Parent.Range(addrs)
        c.Value = "'" & c.Text
    next
end sub

sub escapeSpecialChars(rng)
    excel.DisplayAlerts = False
    rng.Replace vbLf, "\n"
    'rng.Replace vbCr, "\r"
    'rng.Replace vbTab, "\t"
    'rng.Replace """", "\x22"
    'rng.Replace ",", "\x2C"
    excel.DisplayAlerts = True
end sub

sub fillEmptyCells(rng, val)
    dim emptyCells
    set emptyCells = collectEmptyCells(rng)
    if not emptyCells is Nothing then
        emptyCells.Value = val
    end if
end sub

sub toSqlLiterals(rng)
    dim col, c, emptyCells
    for each col in rng.Columns
        set c = col.Find("*", col.Rows(1))
        select case TypeName(c.Value)
            case "Date"     col.NumberFormat = "'yyyy-mm-dd hh:mm:ss'"
            case "String"   col.NumberFormat = "'@'"
            case "Currency" col.NumberFormat = "0.00"
        end select
    next
    set emptyCells = collectEmptyCells(rng)
    if not emptyCells is Nothing then
        emptyCells.NumberFormat = "@"
        emptyCells.Value = "NULL"
    end if
end sub

sub forceQuote(file)
    const ForReading = 1, ForWriting = 2
    dim csv, sep
    if fso.GetExtensionName(file) = "csv" then
        sep = ","
    else
        sep = "\t"
    end if
    with fso.OpenTextFile(file, ForReading)
        csv = .ReadAll
        .Close
    end with
    with new RegExp
        .Pattern = "(""?)((""""|\n|.)*?)\1(" & sep & "|\r\n|$)"
        .Global = True
        csv = .Replace(csv, """$2""$4")
        csv = Left(csv, Len(csv) -2)    ' ゴミとり
    end with
    with fso.OpenTextFile(file, ForWriting)
        .Write(csv)
        .Close
    end with
end sub

sub setLineTerminator(file, eol)
    const ForReading = 1, ForWriting = 2
    dim csv
    with fso.OpenTextFile(file, ForReading)
        csv = .ReadAll
        .Close
    end with
    with fso.OpenTextFile(file, ForWriting)
        .Write(Replace(csv, vbCrLf, eol))
        .Close
    end with
end sub

sub convertToUtf8(file)
    dim ps
    ps = "powershell -c ""&{[IO.File]::WriteAllLines($args[0], $(gc $args[0]))}""" ' PowerShell 2.0以上
    'ps = "powershell -c ""&{[IO.File]::WriteAllText($args[0], $(gc $args[0] -RAW))}""" ' PowerShell3.0以上
    wshShell.run ps & " """ & file & """", 0
end sub

function collectEmptyCells(rng)
    const xlCellTypeBlanks = 4
    set collectEmptyCells = Nothing
on error resume next
    set collectEmptyCells = rng.SpecialCells(xlCellTypeBlanks)
on error goto 0
end function

function collectNumberCells(rng)
    const xlCellTypeConstants = 2, xlNumbers = 1
    set collectNumberCells = Nothing
on error resume next
    set collectNumberCells = rng.SpecialCells(xlCellTypeConstants, xlNumbers)
on error goto 0
end function

'--------------------------------------
' Main
'--------------------------------------
sub Main()
    dim file, ext, folder
    if WScript.Arguments.Count = 0 then
        WScript.Echo("Excelファイルを指定してください")
        exit sub
    end if
    for each file in WScript.Arguments
        file = fso.GetAbsolutePathName(file)
        if not fso.FileExists(file) then 
            WScript.Echo(file & "がありません")
            exit sub
        end if

        ext = fso.GetExtensionName(file)
        if ext <> "xls" and ext <> "xlsx" then
            WScript.Echo(file & "はExcelファイルではありません")
            exit sub
        end if

        folder = wshShell.SpecialFolders("Desktop") & "\" & fso.GetBaseName(file) ' デスクトップに保存
        'folder = fso.GetParentFolderName(file) & "\" & fso.GetBaseName(file) ' xlsファイルと同じ場所に保存
        'folder = wshShell.CurrentDirectory & "\" & fso.GetBaseName(file) ' カレントディレクトリに保存（コマンドライン専用）
        if fso.FileExists(folder) then 
            WScript.Echo(folder & "フォルダーが作成できません")
            exit sub
        elseif not fso.FolderExists(folder) then
            fso.CreateFolder(folder)
        end if

        ' 変換実行
        XlsToCvs file, folder

        'winShell.Explore folder ' CSVを保存したフォルダを Explorer で開く
    next
    WScript.Echo("完了しました")
end sub


Main

excel.Quit
set excel = Nothing
WScript.Quit

使い方

上記スクリプトを任意のファイル名で保存し、拡張子を'.vbs'とする。文字コードは Shift_JIS にすること。UTF-8 だと日本語でエラーになる。

そのスクリプトのアイコンへ Excel ファイル(.xls/.xslx)をおもむろにドラック＆ドロップすると、同名のフォルダがデスクトップに作成され、配下に各シートがCSVファイルとしてエクスポートされる。Excelファイルは複数まとめて渡してもよい。

コマンドラインから実行するには以下のように cscript.exe を使うが、引数のワイルドカードは効かないので悪しからず。

C:\work>cscript xls2csv.vbs Book1.xlsx
Microsoft (R) Windows Script Host Version 5.812
Copyright (C) Microsoft Corporation. All rights reserved.

完了しました

Windows 10 / Excel 2013 で動作確認済み。

もとは Excel の CSV 保存操作を自動化しただけの単純なスクリプトだったが年季が入っていて、デフォルトのいわゆる Excel CSV 形式に加えいろいろカスタマイズできるようになっている。コメントを外すだけなので、ソースとコメントを眺めればだいたいわかると思う。適宜、用途に応じて取捨してほしい。

あくまで技術者向けの公開なので、個人の責任範囲で使用してほしい。またこれを一般の人が使うのはいろいろ問題があってよろしくない。

例えば、エラー処理の手抜きにより異常終了後に残ってしまう Excel プロセスは自分で対処できなければならない。また、WSH/VBScript は古い技術でセキュリティー上の問題があるというのに、内容を確認できない一般の人がvbsファイルの実行に対して警戒心を下げるような機会を今更増やしてしたくはない。

解説というかボヤキ

もとは１０年ぐらい前に書いたスクリプトなのだけど、今でも動かせることにちょっとびっくり。逆に、Excel が相変わらずクソで当時から一つも進歩していないことにもさらにびっくり。それがバグとか設計上のしがらみとかではなく、単なる意図的なイヤがらせだったことは、ああ、今なら分かるよ。

データ範囲外を消去

シートのデータ範囲外のセルが使われていて、CSVにごみデータとなって出力されてしまうのはるのは普通にある。

単体テスト用データを作っているときなど、定数やデータ行に対するメモ（検証内容や項番など）を置いておけると意外と便利だったりする。

clearAround() は指定のセル範囲の外部にあるすべてのセルの値を消去する。数式は値に置き換わるので、消去されるセルへの参照があっても値は壊れない。

余分な空白行・列を除去

どういうわけか、データのないはずの余分な空行や空列がCSV出力に追加されることがある。見かけが空でもExcelには視える幽霊セルがあるらしく、こうなるとそれがいそうな後ろの行や列の辺りを丸ごと削除するしかない。

removeGhoistCells() はその作業を自動で行う。

表示書式を維持

どういうわけか、CSV に出力したときに、値の表示書式か勝手に変えられてしまうことがある。日付、時刻、通貨などが影響を受けるようだが、特に日付が米国式になってしまうのは腹立たしい。

Excel はセルの書式（表示形式）を、米国に合わせた基本書式とロケール依存の地域書式の２重で持っていて、両者に違いがある場合、CSV出力ではロケールに依存しない基本書式（米国書式）が優先される。Excel の「セルの表示設定」＞｛表示形式」画面で先頭にアスタリスク(*)がついている書式がそれらしい。

keepLocalFormat()は地域書式で基本書式を上書きする。

条件付き書式を維持

どういうわけか、条件付き書式は CSV 出力に適用されない。

条件付き書式なんて使ったことあるだろうか。まあ、データ用のシートに条件付き書式が使われることはないだろうし、AVIVAへでも行かない限りほとんどの技術者には無縁な話だ。

keepConditionalFormat()は、セルに条件付き書式があれば現在の表示文字列をセル値に設定する。ただしループで各セルを更新するので重い処理になる。

特殊文字をエスケープ

Excel のセル内改行は CSV 出力では LF として出力される。レコードを１行に納めたい場合 LF をエスケープしておきたい。

escapeSpecialChars() はセル文字列の LF を"¥n"に置換する。ただの文字列置換なので、必要ならそれ以外のパターンも追加できる。

空セルに値を設定

セルに値が入っていないと、CSV出力ではフィールドが空になる。取り込み側の仕様によっては、NULLや\Nなど空値を示すキーワードを入れたい。

fillEmptyCells()は全ての空セルに指定の値をセットする。

空とNULLを区別したいこともある。空フィールドのままにしておきたいセルには、あらかじめシングルクオート(')のみを入力しておけばいい。シングルクオートのみのセルは空文字列を値としてもつセルであり、空セルとは判定されなくなるので空値の設定対象とはならないが、CSV出力では値のない空フィールドになる。もう、自分でも何を言っているのかわからない。

SQL のリテラル表現

いっそ、INSERT 文を生成させたくなるのも無理はない。

toSqlLiterals()はそれ用のつもりだったが、まだやりかけのようだ。中途半端なのであてにしないでほしい。もう少し何とかできたはずなのだが、今更やる気も起きない。

全てのフィールドを引用符付け

Excel CSV は基本的に各フィールドをクオートなしで出力する。ただし、値に改行、カンマ(,)、ダブルクオート(")などが含まれる場合に、そのフィールドはダブルクオートで囲まれる。

どうせなら全てのフィールドをダブルクオートで囲んでもらった方が取り込み側の処理が楽になる。

forceQuote() は全てのフィールドにダブルクオート囲みを追加する。

レコード区切りを変更

デフォルトのレコード区切は改行コード(CRLF)。

setLineTerminator() は CRLF を任意の文字列で置換する。セル内改行（LF）は置換されない。

BOMなしUTF-8に変換

どういうわけか、Excel や WSH は UTF-8 出力をサポートしない。Windows 界隈でいうユニコードサポートとはUTF16(LE)のことだったりする。

PowerShell が出てやっと UTF-8 が使えるようになった。

しかしそれは、本当に腹立たしいことだが、それは BOM 付き UTF-8 という、本当に意味の分からない、本当にヘンな、余計な、この、本当に、クビを絞めてやｒｙ

convertToUtf8()は、Shift_JIS を BOM なしの UTF-8 に変換する。WSH からPowerShell スクリプトを起動して実現しているのは負けだ。

改行コードが全て（セル内改行も含めて） CRLF に書き戻されてしまうので注意。それは困ることでもないが、困るという場合、 PowerShell 3.0 以上の環境であれば、コメントアウトされている２つめの PowerShell スクリプトで対応できそうな感じなので試してほしい。

WSH/VBScript について

以下に詳しい。

レガシー環境のためのWindows Script Host(WSH)の解説 - Qiita

WSH/VBScript はオワコンなので、今から学習する価値は乏しい。要望があれば隣の席のハゲたおっさんに投げてほしい。