ファイルの数が多いと面倒な作業をVBAで自動化
最近仕事でWordのファイルを大量にPDFに変更する必要がありました。
1つ2つくらいのファイルなら手作業で済ませるのですが、今回は50件行う必要があり、また他のタイミングでも継続的に業務として発生することが決まっていました。
そこで、(サラリーマンらしくこの作業は本当に必要あるのかは考えるのをやめて)VBAで自動化の方法を考えてみました。
Excelのシートに対象のファイルを書き出す
WordのVBAは使いにくいですし、もともと大量のファイルを処理することが前提でしたので、ExcelのワークシートとExcelVBAを使用することにしています。
私の経験上この組み合わせはExcelのファイルを操作するだけでなく、色々な業務で使いやすいと思います。
手順は下記の3ステップを想定しています。
スポンサーリンク
今回使用するワークシート
今回使用するワークシートは下記の通りです。
対象ファイルを特定のフォルダにまとめて格納しておけば一括でファイル名を取得できるようにしています。
作成したExcelVBAコードと実行手順について
①ファイル名一覧の取得
まず①Wordファイル一覧を一括取得するExcelVBAコードは下記の通りです。
実行するとファイルの選択ダイアログが開き、対象ファイルの一つを選択するとそのフォルダにあるWordファイルのパスとファイル名をA列に記入します。
Dim FolderName As String ’文字列を入れる変数として「FolderName」を使う
Dim index As Integer ’数字を入れる変数として「index」を使う
Dim FileName As String ’文字列を入れる変数として「FileName」を使う
FolderName = Application.GetOpenFilename ’ダイアログを用いて選択したファイルのパスをFolderNameとする①
Dim i
If FolderName = “False” Then ’FolderNameが選択されていなければ作業を終了する
Exit Sub
End If
’今のフォルダ名には選択したファイル名含まれているので、ファイル名の部分を切り取る作業。
index = InStrRev(FolderName, “”) ’フォルダ名部分の文字数をカウントする
FolderName = Left(FolderName, index) ’ カウントした文字数までの部分を切り取ってフォルダ名とする
FileName = Dir(FolderName & “*docx”) ’ フォルダの中に含まれるファイルを取り出す
i = 2
Do While FileName <> “” ’ ファイルがなくなるまで繰り返す
ThisWorkbook.ActiveSheet.Cells(i, 1) = FolderName & FileName ’ 変更を行う
i = i + 1
FileName = Dir() ’
Loop
End Sub
②PDFとして出力する際のファイル名の記入
出力先フォルダとファイル名はC列に入力してから出力を開始します。
ExcelのSubstitute関数やVBAのReplace関数を使って自動で表記することも可能です。
一例ですが、デスクトップにある「Wordファイル」というフォルダから同じくデスクトップにある「PDFファイル」というフォルダに拡張子以外の部分を同じファイル名で出力する場合にはC2セルに下記のように関数を入力しておきます。
(「.docx」を「.pdf」に置換、「Wordファイル」を「PDFファイル」に置換しているだけです。)
③一覧に記載されているWordファイルを順にPDFとして出力する
WordファイルをPDFとして出力するコードは下記の通りです。
実行するとC列に記載したフォルダ・ファイル名でPDFが出力されます。
Dim objWord As Word.Application
Set objWord = CreateObject(“Word.Application”)
objWord.Visible = True
Dim objDoc As Word.Document
Dim FileName As String
Dim i
i = 2
Do While Cells(i, 1) <> “” ’ ファイルがなくなるまで繰り返す
FileName = Cells(i, 1)
Set objDoc = objWord.Documents.Open(FileName)
objDoc.ExportAsFixedFormat OutputFileName:=Cells(i, 3), ExportFormat:=wdExportFormatPDF
objDoc.Close
Set objDoc = Nothing
i = i + 1
Loop
objWord.Quit
Set objWord = Nothing
End Sub
コメント