コピペプログ

VBA、VBS、バッチファイルなどの備忘録と日記です。

【VBScript】WordをExcelに一括変換する

Word VBScript Excel 開発

WordをExcelに変換するには一旦HTML形式に変換保存後、HTMLファイルをExcelで保存します。 非常に手間がかかるので多量のファイルを変換するのは大変です。 ネット上にはWordからHTML、ExcelからHTMLはよく見つかりますが、WordからExcelがなかったので 作りました。

'------------------------------------------------------------------------------------------------------------------
Option Explicit
'IE の宣言と初期化
Dim ie
initializeIe()
updateMsg "処理を開始します..."
'---------------------------------------------------------------------------------------------------
'ドラッグ&ドロップされたフォルダの処理
Dim Args  

Set Args = WScript.Arguments
If Args.Count <> 1 Then '処理できるのは１フォルダのみ
    WScript.Echo "当スクリプトに対象となる１フォルダをドラッグ&ドロップして処理を実行してください。"
    WScript.Quit    'スクリプトを終了
End If

'フォルダ判別
With CreateObject("Scripting.FileSystemObject") '以下の処理はEnd WithまでScripting.FileSystemObjectを使用
    If .FolderExists(Args(0)) = False Then  'ドラッグされたものを解析
        WScript.Echo "フォルダが見つかりません。" & vbCrLf & "あるいはフォルダではありません。"
        closeIe()
        WScript.Quit
    End If
End With

'Wordファイルの有無チェック「IsExistsParticularFile」に処理渡した結果下で処理
If (IsExistsParticularFile(Args(0), "doc") = False) And (IsExistsParticularFile(Args(0), "docx") = False) Then
    WScript.Echo "指定したフォルダ内にWordファイルが見つかりませんでした。"
    closeIe()
    WScript.Quit
End If

' 処理…
updateMsg "HTML変換処理を実行しています..."
WScript.Sleep 5000  ' サンプル用・処理している風に少し止める

ConvertWordToHtml Args(0) 'WordToHtmlへWScript.Argumentsを渡して呼び出し。フォルダパスとかファイル名とか。

updateMsg "Excel変換処理を実行しています..."
WScript.Sleep 5000  ' サンプル用・処理している風に少し止める

ConvertHtmlToExcel Args(0) 'WordToExcelへWScript.Argumentsを渡して呼び出し。フォルダパスとかファイル名とか。

' 完了
updateMsg "スクリプト処理完了!"
WScript.Echo "処理が終了しました。"
' IE を終了させスクリプトを閉じる
closeIe()
WScript.Quit
'------------------------------------------------------------------------------------------------------------------
Private Sub ConvertWordToHtml(ByVal FolderPath)
'指定したフォルダ内のWordファイルをHTMLファイルに変換
Dim wdApp, wdDoc
Dim f

Const wdFormatHTML = 8 '保存時に使用するフォーマット番号を「wdFormatHTML」に設定（標準 HTML 形式）
Const wdDoNotSaveChanges = 0 '変更がない時に保留中の変更を保存しません。この２つは番号で記述すると何だこれとなるから定数設定する
Set wdApp = CreateObject("Word.Application")     'Wordのオブジェクトを作成
wdApp.Visible = False 'Wordアプリを非表示
  
If Right(FolderPath, 1) <> ChrW(92) Then FolderPath = FolderPath & ChrW(92) 'FolderPath末尾￥をつける処理 ChrW(92)は「￥」Chr 【ｷｬﾗｸﾀｰ】関数
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(FolderPath).Files 'ファイルの数だけ繰り返し処理
            Select Case LCase(.GetExtensionName(f)) 'ファイル形式が当てはまれば処理
        'Wordファイルのみ処理
            Case "doc", "docx"
                Set wdDoc = wdApp.Documents.Open(CStr(f)) 'Wordで対象ファイルを開く
                wdDoc.SaveAs FolderPath & .GetBaseName(f) & ".html", wdFormatHTML, , , False 'HTM形式で保存する
                wdDoc.Close wdDoNotSaveChanges '対象ファイル閉じる
                Set wdDoc = Nothing '変数の片付け
        End Select
    Next
End With
wdApp.Quit 'Wordアプリを終了
End Sub
'------------------------------------------------------------------------------------------------------------------

Private Sub ConvertHtmlToExcel(ByVal FolderPath)
'htmlからExcelに変換
Dim objExcel, fso, folder, subfolder, Exbook
Dim f
  
Set objExcel = CreateObject("Excel.Application") 'Excelのオブジェクトを作成
  
objExcel.Visible = False 'Excelアプリを非表示
If Right(FolderPath, 1) <> ChrW(92) Then FolderPath = FolderPath & ChrW(92) 'FolderPath末尾￥をつける処理 ChrW(92)は「￥」Chr 【ｷｬﾗｸﾀｰ】関数
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(FolderPath).Files
            Select Case LCase(.GetExtensionName(f))
        'htmlファイルのみ処理
            Case "html"
                Set Exbook = objExcel.Workbooks.Open(CStr(f))   'ファイルを開く
                Exbook.SaveAs FolderPath & .GetBaseName(f) & ".xlsx",51 'ここは保存形式をxlsx形式の保存だが番号のままConstで定義しといてもよい
                Exbook.Close '対象ファイル閉じる
                f.Delete  'htmlファイルを削除
                Set Exbook = Nothing
            End Select
        Next
    End With
objExcel.Quit 'Excel終了
'HTMLに変換するときにできたフォルダを削除
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(FolderPath) 'folderにドラッグ&ドロップしたFolderPathを格納
  
For Each subfolder In folder.subfolders 'folder.subfoldersサブフォルダの数だけ処理
    subfolder.Delete (True)        ' フォルダを削除
Next
Set fso = Nothing '変数の片付け
End Sub
'------------------------------------------------------------------------------------------------------------------

Private Function IsExistsParticularFile(ByVal FolderPath, ByVal FileExtension)
'指定したフォルダ内に特定の拡張子のファイルがあるかを調べる
Dim ret
Dim f
 
ret = False '初期化
With CreateObject("Scripting.FileSystemObject")
    For Each f In .GetFolder(FolderPath).Files
        Select Case LCase(.GetExtensionName(f))
        Case LCase(FileExtension)
            ret = True
            Exit For
        End Select
    Next
End With
IsExistsParticularFile = ret
End Function

'------------------------------------------------------------------------------------------------------------------
' IE の初期化
Sub initializeIe()
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Navigate("about:blank")
    .ToolBar = False
    .StatusBar = False
    ' 幅・高さの設定
    .Width = 300
    .Height = 200
    ' 画面右上に配置する。"parentWindow.screen" はパスカルケースで書くと認識されない
    .Top = 0
    .Left = .Document.parentWindow.screen.Width - 300
    .Document.Charset = "UTF-8"
    .Visible = True
    .Document.Title = "スクリプト実行中"
  End With
End Sub
'------------------------------------------------------------------------------------------------------------------
' メッセージを IE に追記する
' 
' 引数のメッセージを IE の最終行に追記する。
' 最終行が表示されるようにスクロール位置を最下部に設定する。
Sub updateMsg(value)
  With ie
    .Document.Body.innerHTML = .Document.Body.innerHTML & value & "<br>"
    .Document.Script.setTimeout "javascript:scrollTo(0," & .Document.Body.ScrollHeight & ");", 0
  End With
End Sub

' IE を終了する
Sub closeIe()
  ie.Quit
  Set ie = Nothing
End Sub