Excel シートを CSV でエクスポートする VBScript
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
' ファイル形式を指定して1シートを保存
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ファイルの実行に対して警戒心を下げるような機会を今更増やしてしたくはない。
解説というかボヤキ
もとは10年ぐらい前に書いたスクリプトなのだけど、今でも動かせることにちょっとびっくり。逆に、Excel が相変わらずクソで当時から一つも進歩していないことにもさらにびっくり。それがバグとか設計上のしがらみとかではなく、単なる意図的なイヤがらせだったことは、ああ、今なら分かるよ。
データ範囲外を消去
シートのデータ範囲外のセルが使われていて、CSVにごみデータとなって出力されてしまうのはるのは普通にある。
単体テスト用データを作っているときなど、定数やデータ行に対するメモ(検証内容や項番など)を置いておけると意外と便利だったりする。
clearAround()
は指定のセル範囲の外部にあるすべてのセルの値を消去する。数式は値に置き換わるので、消去されるセルへの参照があっても値は壊れない。
余分な空白行・列を除去
どういうわけか、データのないはずの余分な空行や空列がCSV出力に追加されることがある。見かけが空でもExcelには視える幽霊セルがあるらしく、こうなるとそれがいそうな後ろの行や列の辺りを丸ごと削除するしかない。
removeGhoistCells()
はその作業を自動で行う。
表示書式を維持
どういうわけか、CSV に出力したときに、値の表示書式か勝手に変えられてしまうことがある。日付、時刻、通貨などが影響を受けるようだが、特に日付が米国式になってしまうのは腹立たしい。
Excel はセルの書式(表示形式)を、米国に合わせた基本書式とロケール依存の地域書式の2重で持っていて、両者に違いがある場合、CSV出力ではロケールに依存しない基本書式(米国書式)が優先される。Excel の「セルの表示設定」>{表示形式」画面で先頭にアスタリスク(*)がついている書式がそれらしい。
keepLocalFormat()
は地域書式で基本書式を上書きする。
条件付き書式を維持
どういうわけか、条件付き書式は CSV 出力に適用されない。
条件付き書式なんて使ったことあるだろうか。まあ、データ用のシートに条件付き書式が使われることはないだろうし、AVIVAへでも行かない限りほとんどの技術者には無縁な話だ。
keepConditionalFormat()
は、セルに条件付き書式があれば現在の表示文字列をセル値に設定する。ただしループで各セルを更新するので重い処理になる。
特殊文字をエスケープ
Excel のセル内改行は CSV 出力では LF として出力される。レコードを1行に納めたい場合 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 という、本当に意味の分からない、本当にヘンな、余計な、この、本当に、クビを絞めてやry
convertToUtf8()
は、Shift_JIS を BOM なしの UTF-8 に変換する。WSH からPowerShell スクリプトを起動して実現しているのは負けだ。
改行コードが全て(セル内改行も含めて) CRLF に書き戻されてしまうので注意。それは困ることでもないが、困るという場合、 PowerShell 3.0 以上の環境であれば、コメントアウトされている2つめの PowerShell スクリプトで対応できそうな感じなので試してほしい。
WSH/VBScript について
以下に詳しい。
レガシー環境のためのWindows Script Host(WSH)の解説 - Qiita
WSH/VBScript はオワコンなので、今から学習する価値は乏しい。要望があれば隣の席のハゲたおっさんに投げてほしい。