【VBScript】csv⇒Excelに変換&セル書式を文字列にする

ExcelでCSVファイルを開くと、例えば


  • 頭の0が消えてしまう

  • コード値がなぜか日付に変換されてしまう

などの事象が起こります。

回避するためには、


  • Excelを開いた後でセルの書式設定を文字列にする

  • カンマ区切りでセル分割する

をやれば直るのですが、それが面倒(というか↑ができない)なユーザー向けにスクリプトを書いてみました。

僕自身のVBScriptの学習教材として、良い勉強になりましたので備忘録がてら載せておきます。

※半日くらいで作ったものなのでソースは汚いです。ご了承下さい><


前提

こんなCSVファイルがあるとします。

image.png

Excelで開くとテストNo列が日付になってしまっています。

image.png


使い方

①csv⇒xlsx変換.vbsにtest.csvをドラッグ&ドロップ

image.png

②こんな感じで進捗度を表示しつつ、CSV⇒EXCEL変換処理を行います

image.png

③処理完了後、生成されたExcelファイルを開くと各列が文字列セルに変換されています

image.png


ソースコード


csv⇒xlsx変換.vbs

Option Explicit

On
Error Resume Next

' 引数より対象ファイル名を取得する
Dim GetPathArray, objFSO, objExcel, ObjIE
Set GetPathArray = WScript.Arguments
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objIE = CreateObject("InternetExplorer.Application")

Dim pt, addCount, totalCount
addCount = 0
totalCount = 0

' Excelプロセス存在確認
If checkExcelProc(1) = False Then
MsgBox "Excelファイルを閉じてから再度実行してください。処理を終了します。"
closeObject()

WScript.Quit
Else
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = False
End If

If GetPathArray.Count = 0 Then
MsgBox "処理対象CSVファイルをドラッグ&ドロップしてください。処理を終了します。"
closeObject()
WScript.Quit
Else
initIE()
totalCount = getTotalCount(GetPathArray)
End If

' ファイルごとに行数分ループ開始
For Each pt in GetPathArray
Dim ext
ext = objFSO.GetExtensionName(pt)

If ext = "csv" Then

Dim ts, rowCount, columnCount
Set ts = objFSO.OpenTextFile(pt)

rowCount = 0
columnCount = 0

Do While ts.AtEndOfstream <> True
Dim lineData, spLineData
lineData = ts.readLine()
spLineData = Split(lineData, ",")

' ヘッダーのカラム数を取得
If rowCount = 0 Then
' 新規Excelファイルを作成
Dim xlBook
Set xlBook = objExcel.Workbooks.Add

xlBook.SaveAs(Replace(pt, ".csv", ".xlsx"))

columnCount = UBound(spLineData)

Dim i
For i = 0 To columnCount
' システム番号列のセル書式を文字列にする
xlBook.Worksheets(1).Columns(i + 1).NumberFormatLocal = "@"
Next

End If

' 記入処理
If lineData <> "" Then
Dim k
For k = 0 To columnCount
xlBook.Worksheets(1).Cells(rowCount + 1, k + 1).Value = spLineData(k)
Next

Else
xlBook.Worksheets(1).Cells(rowCount + 1, 1).Value = lineData
End If

rowCount = rowCount + 1
addCount = addCount + 1

' 進捗度を進める
updateMsg "(" & Round((addCount / totalCount) * 100, 0) & "%)"

Loop

' ファイル保存
xlBook.Save
xlBook.Close
Set xlBook = Nothing

ts.Close
Set ts = Nothing

Else
MsgBox objFSO.GetFileName(pt) & vbCrLf & _
"csvファイルでないため、処理をスキップします。", vbSystemModal
End If

If Err.Number <> 0 Then
MsgBox "エラーが発生しました。" & vbCrLf & _
"ファイル名:" & objFSO.GetFileName(pt) & vbCrLf & _
"エラー番号:" & Err.Number & vbCrLf & _
"エラー詳細:" & Err.Description
End If

Next

' オブジェクトクローズ
closeObject()

' Excelプロセス終了
checkExcelProc(2)

Set GetPathArray = Nothing

If Err.Number <> 0 Then
MsgBox "ロボット処理を終了しました。", vbSystemModal
Else
MsgBox "変換完了しました。", vbSystemModal
End If

' プログレスバー初期設定
Sub initIE()
With objIE
.Navigate("about:blank")
.Height = 200
.Width = 300
.Top = .Document.parentWindow.screen.Height / 2
.Left = .Document.parentWindow.screen.Width / 2
.Document.CharSet = "UTF-8"
.Document.Title = "スクリプト実行中"
.AddressBar = False
.StatusBar = False
.MenuBar = False
.ToolBar = False
.Resizable = False
.Visible = True
End With
End Sub

' 処理総件数取得
Function getTotalCount(arg)
Dim tmpPt, tmpCount
tmpCount = 0

For Each tmpPt in arg
Dim cnt, tmpTs, tmpExt
cnt = 0
Set tmpTs = objFSO.OpenTextFile(tmpPt)
tmpExt = objFSO.GetExtensionName(tmpPt)

If tmpExt = "csv" Then
Do While tmpTs.AtEndOfstream <> True
tmpCount = tmpCount + 1
cnt = cnt + 1
tmpTs.ReadLine()
Loop

tmpTs.Close
Set tmpTs = Nothing

End If
Next

getTotalCount = tmpCount

End Function

' メッセージ更新
Sub updateMsg(val)
With objIE
.Document.Body.innerHTML = val
.Document.Script.setTimeout "javascript:ScrollTo(0," & .Document.Body.ScrollHeight & ");", 0
End With
End Sub

' オブジェクトを閉じる
Sub closeObject()
objIE.Quit
Set objIE = Nothing

Set objFSO = Nothing

objExcel.Quit
Set objExcel = Nothing

End Sub

' Excelプロセスチェック
' 引数⇒1:Excelプロセス存在確認 2:Excelプロセス終了
Function checkExcelProc(val)
Dim result, objProcList, objProcess
result = True
Set objProcList = GetObject("winmgmts:").InstancesOf("win32_process")

For Each objProcess In objProcList
If LCase(objProcess.Name) = "excel.exe" Then
If val = 1 Then
result = True
Else
objProcess.Terminate
result = False
End If
Else
End If
Next

Set objProcList = Nothing

checkExcelProc = result

End Function