2017年6月
        1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30  

« ¥Money(投信生活070623) | トップページ | ▼ダイエット大作戦(やっと82Kg) »

2007年6月23日 (土)

■Word VBA(定型フォーマットのWordを一気に開いて複数作成するマクロ)

以前「定型フォーマットのExcelを一気に開いて複数作成するマクロ」シリーズをやった際に、定型フォーマットはWordでもできますよとコメントしましたが、今回はその例をご紹介いたします。
仕様はExcelと同じです。フォーマットもExcelと同じにしてみました。
詳細はこちらをご確認ください。http://peiyorin.cocolog-nifty.com/blog/2007/05/excel_vba_2f7d.html
以下がそのマクロです。

'申請書一覧
Const cStRow As Integer = 3
Const 部署col As Integer = 2
Const 申請者col As Integer = 3
Const 承認者col As Integer = 4
Const 承認日col As Integer = 5
Const 機能名col As Integer = 6
Const 依頼事項col As Integer = 7
Const 処理日col As Integer = 8
Const ファイル名col As Integer = 9
Const 更新日col As Integer = 10

Sub Wordファイル取り込み()
    Const cDefPath As String = "c:\work"
    Const cMyWs As String = "申請一覧"
   
    Set oMyWs = ThisWorkbook.Sheets(cMyWs)
   
    'クリア確認
    If vbYes = MsgBox("一覧をクリアしますか?", vbYesNo + vbQuestion, "クリア確認") Then
        lLastRow = oMyWs.Cells(65500, 部署col).End(xlUp).Row + 1
        oMyWs.Range(oMyWs.Cells(cStRow, 部署col), oMyWs.Cells(lLastRow, 更新日col)).ClearContents
    End If
   
    'フォルダ指定
    ChDrive Left(cDefPath, 1)
    ChDir cDefPath
    FileDir = Application.GetSaveAsFilename("DUMMY", "Wordファイル(*.doc),*.doc", , "■■■ フォルダ指定 ■■■")
    If FileDir = "False" Or FileDir = "FALSE" Then Exit Sub
    FileDir = Mid(FileDir, 1, InStrRev(FileDir, "\") - 1)
   
   
    'ファイル情報取り込み
    Set wd = CreateObject("Word.application")
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.getFolder(FileDir)
   
    For Each oF In f.Files
        If Not (IsNumeric(Left(oF.Name, 8))) Then GoTo next_oF
        If Not (oF.Name Like "*.doc") Then GoTo next_oF
       
        Set oActDoc = wd.documents.Open(Filename:=FileDir & "\" & oF.Name, ReadOnly:=True)
       
        For Each oTb In oActDoc.Tables
            lLastRow = oMyWs.Cells(65500, 部署col).End(xlUp).Row + 1
            oMyWs.Cells(lLastRow, 部署col).Value = Application.Substitute(oTb.Range.Rows(1).Range.Cells(2).Range.Text, "", "")
            oMyWs.Cells(lLastRow, 申請者col).Value = Application.Substitute(oTb.Range.Rows(3).Range.Cells(2).Range.Text, "", "")
            oMyWs.Cells(lLastRow, 承認者col).Value = Application.Substitute(oTb.Range.Rows(5).Range.Cells(2).Range.Text, "", "")
            oMyWs.Cells(lLastRow, 承認日col).Value = Application.Substitute(oTb.Range.Rows(7).Range.Cells(2).Range.Text, "", "")
            oMyWs.Cells(lLastRow, 機能名col).Value = Application.Substitute(oTb.Range.Rows(9).Range.Cells(2).Range.Text, "", "")
            oMyWs.Cells(lLastRow, 依頼事項col).Value = Application.Substitute(oTb.Range.Rows(11).Range.Cells(2).Range.Text, "", "")
            oMyWs.Cells(lLastRow, 処理日col).Value = Now()
            oMyWs.Cells(lLastRow, ファイル名col).Value = oF.Name
            oMyWs.Cells(lLastRow, 更新日col).Value = oF.DateLastModified
        Next
        oActDoc.Close
next_oF:
    Next

    Set fs = Nothing
    Set f = Nothing
    Set oF = Nothing
    Set wd = Nothing
    Set oDc = Nothing
    Set oTb = Nothing
    Set oActDoc = Nothing
   
End Sub

それでは解説していきます。まず始めに、前回は申請書一覧.xlsにボタンを用意してExcelファイルを一覧化していましたが、同様にWordファイルを取り込むためのボタンを追加して、上記マクロを実行するように設定します。
でこれも前回と同様ですが、申請書一覧の列位置情報を定義しています。これは前回の記述と冗長ですが気になる方はもちろん一つに集約して頂いて結構です。で、実際の処理ですが、基本構造は前回のExcel版と変わりませんのでWord固有の部分に絞って解説します。「ファイル情報取り込み」では、Set wd = CreateObject("Word.application")でWordオブジェクトを生成し、Set oActDoc = wd.documents.OpenでWordファイルを読み取り専用でオープンし、For Each oTb In oActDoc.TablesでWord文書のテーブル情報を取得して繰返し処理を行っています。Wordに表を作成した場合はTablesで情報を取得することになります。そのテーブルに対して、Application.Substitute(oTb.Range.Rows(1).Range.Cells(2).Range.Text, "", "")という命令で一つ一つのセルごとに情報を取得します。Range.Rows(1)が行、
Range.Cells(2)が列の配列を表します。Substituteで""を""に変換していますがこれは変換しなかった場合と変換した場合を試してみれば解ると思います。oActDoc.CloseでオープンしたWordファイルをクローズして1ファイル分終了です。これを指定したフォルダ配下のWordファイル分処理を繰り返すというわけです。

申請書一覧.xlsの改訂版と定型フォーマットのWordファイルをアップロードしますので実際に動作させて確認してみてくださいね。

「sinsei_sample2.EXE」をダウンロード

« ¥Money(投信生活070623) | トップページ | ▼ダイエット大作戦(やっと82Kg) »

パソコン・インターネット」カテゴリの記事

コメント

コメントを書く

(ウェブ上には掲載しません)

« ¥Money(投信生活070623) | トップページ | ▼ダイエット大作戦(やっと82Kg) »