Word (VBA)

Word VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Word 2013)
コードの高速化
投稿日時: 19/04/08 13:49:47
投稿者: たかみ

外部から入手した書類や技術資料といった、書式が統一ではない紙媒体のものをスキャン・PDF化する作業が頻繁にあり、スキャニングしたものですから当たり前なんですが、しおりを付けたければ手作業でするしかありません。
しかし、毎回数百ページクラスになる資料類ばかりでしおりの数も数百ということがほとんどなので、なんとかVBAでしおり付けができないかと考え、しおりデータの入力はExcelで行い、Wordでしおりデータを元に見出しタイトルを作成し、しおりを付けたいpdfファイルと同ページ数の白紙のpdfファイルに変換して、出来上がったしおり付きファイルに対して、元ファイルのページを置換すればいいのでは?と思いつきました。
 
コードは出来上がったのですが、下記のテストデータのような総ページ数30ページほどのファイル作成でも、6秒ほどかかります。
数百ページ分のテストデータで実行したところ、終了まで1分近くかかりました。
 

            A               B           C         D     
  ┌─────────┬──────┬─────┬────┐
  1│しおり名          │しおりレベル│ページ番号│総ページ│
  ├─────────┼──────┼─────┼────┤
  2│第1節計画         │           1│        10│      30│
  ├─────────┼──────┼─────┼────┘
  3│第1項共通編       │           2│        10│         
  ├─────────┼──────┼─────┤     
  4│1-1基本理念       │           3│        10│         
  ├─────────┼──────┼─────┤     
  5│1-2書籍について   │           3│        11│         
  ├─────────┼──────┼─────┤     
  6│1-3計画について   │           3│        11│         
  ├─────────┼──────┼─────┤     
  7│1-3-1期間の決定   │           4│        11│         
  ├─────────┼──────┼─────┤     
  8│1-3-2基本事項     │           4│        11│         
  ├─────────┼──────┼─────┤     
  9│1-4業務について   │           3│        14│         
  ├─────────┼──────┼─────┤     
 10│1-4-1予備業務     │           4│        14│         
  ├─────────┼──────┼─────┤     
 11│1-4-2本業務       │           4│        15│         
  ├─────────┼──────┼─────┤     
 12│1-4-3実施計画     │           4│        16│         
  ├─────────┼──────┼─────┤     
 13│1-4-4留意事項     │           4│        16│         
  ├─────────┼──────┼─────┤     
 14│1-5チェック体制   │           3│        19│         
  ├─────────┼──────┼─────┤     
 15│1-5-1概要         │           4│        19│         
  ├─────────┼──────┼─────┤     
 16│1-5-2チェック項目 │           4│        19│         
  ├─────────┼──────┼─────┤     
 17│第2項調査編       │           2│        23│         
  ├─────────┼──────┼─────┤     
 18│2-1調査           │           3│        23│         
  ├─────────┼──────┼─────┤     
 19│2-1-1資料収集     │           4│        23│         
  ├─────────┼──────┼─────┤     
 20│2-1-2現況調査     │           4│        23│         
  ├─────────┼──────┼─────┤     
 21│2-2調査の実施     │           3│        25│         
  ├─────────┼──────┼─────┤     
 22│2-2-1予備調査     │           4│        25│         
  ├─────────┼──────┼─────┤     
 23│2-2-2最終調査     │           4│        25│         
  ├─────────┼──────┼─────┤     
 24│2-2-3広報         │           4│        25│         
  ├─────────┼──────┼─────┤     
 25│2-2-4説明会       │           4│        25│         
  ├─────────┼──────┼─────┤     
 26│2-2-5見直し       │           4│        25│         
  └─────────┴──────┴─────┘     

 
 ページ数分の「ページ区切りの挿入」を繰り返していることが最大の原因だとは思うんですが、Word_VBAを勉強し始めて半月弱という状態な上に、Excel_VBAと比べてWord_VBAは情報が少ないものですから、これ以上の方法が思いつきません。
もっと高速にする方法などありましたら、アドバイスをいただけませんでしょうか。
ツリー状にしたしおりを作成するにはWordでないと無理だと思っているだけで、Wordにこだわらなくてもツリー状のしおりが作成できればいいのです。
Word以外で高速化できる方法がありましたら、そのアドバイスもいただけますと嬉しいです。
 
ちなみに、Acrobat社が公開している「IAC」機能を使ってしおりをつけるコードは作成済で、こちらは本当に一瞬で終わるのですが、出来上がったしおりが、Excel・WordやAcrobatの標準機能で付けたしおりとはちょっと違っており、挙動がおかしいわけではないのでこちらで十分だと思うのですが、Excel・WordやAcrobatの標準機能で付けたしおりのようなものにしたくて、今回のWord_VBAでやってみたいということになりました。
 
以下が現状できているコードです。
 
Sub しおり作成テスト()
Dim objWord As New Word.Application
Dim objWordDoc As Word.Document
Dim i As Long, j As Long, GYO As Long, cnt As Long
Dim objWS As Worksheet
    
    Application.ScreenUpdating = False
    
    Set objWS = ThisWorkbook.Worksheets("しおり作成")
    GYO = objWS.Range("A" & Rows.Count).End(xlUp).Row
    objWS.Range("A2:A" & GYO).Copy
    
    With objWord
        'Wordを表示
        .Visible = False
        '文書を新規作成
        .Documents.Add
        '新規文書をオブジェクト変数に代入
        Set objWordDoc = .ActiveDocument
    End With
    
    'しおり作成
    With objWord.Selection
        .PasteSpecial Link:=False, DataType:=wdPasteText, Placement:=wdInLine, DisplayAsIcon:=False '文書にテキストを貼り付け
        
        .HomeKey Unit:=wdStory '文書の先頭に移動
        
        For i = 2 To GYO
            .Style = objWordDoc.Styles("見出し " & objWS.Range("B" & i).Value)
            .MoveDown Unit:=wdLine, Count:=1
        Next i
        
        .HomeKey Unit:=wdStory '文書の先頭に移動
        
        If objWS.Range("C2").Value = 1 Then
            .MoveDown Unit:=wdLine, Count:=1
        ElseIf objWS.Range("C2").Value > 1 Then
            j = 1
            Do While objWS.Range("C2").Value > j
                .InsertBreak Type:=wdPageBreak
                j = j + 1
            Loop
            .MoveDown Unit:=wdLine, Count:=1
            .HomeKey Unit:=wdLine, Extend:=wdMove
        End If
        
        
        For i = 3 To GYO
            
            cnt = objWS.Range("C" & i).Value - objWS.Range("C" & i - 1).Value
            
            Select Case cnt
                Case 0
                    .MoveDown Unit:=wdLine, Count:=1
                    .HomeKey Unit:=wdLine, Extend:=wdMove
                Case Is >= 1
                    j = 1
                    Do While cnt >= j
                        .InsertBreak Type:=wdPageBreak
                        j = j + 1
                    Loop
                    .MoveDown Unit:=wdLine, Count:=1
                    .HomeKey Unit:=wdLine, Extend:=wdMove
            End Select
        
        Next i
        
        .EndKey Unit:=wdStory '文書の末尾に移動
        
        cnt = objWS.Range("D2").Value - objWS.Range("C" & GYO).Value
        
        If Not cnt = 0 Then
            i = 1
            
            Do While cnt >= i
                .InsertBreak Type:=wdPageBreak
                i = i + 1
            Loop
        End If
    End With
        
    '新規文書を名前を付けて保存
    objWordDoc.SaveAs2 "D:\WORD_VBA\" & "目次テスト.docx"
        
    '文書をPDFに変換
    objWordDoc.ExportAsFixedFormat ExportFormat:=wdExportFormatPDF, OutputFileName:="D:\WORD_VBA\" & "目次テスト.pdf" _
    , CreateBookmarks:=wdExportCreateHeadingBookmarks
    
    '文書を閉じる
    objWordDoc.Close
    
    objWord.Quit
    Set objWord = Nothing
    Set objWordDoc = Nothing
    
    Set objWS = Nothing
    
    Application.ScreenUpdating = True

End Sub

 
 
以上です。
よろしくお願いいたします。

回答
投稿日時: 19/04/09 11:19:32
投稿者: sk

引用:
コードの高速化

引用:
もっと高速にする方法などありましたら、アドバイスをいただけませんでしょうか。

例示されたコードに関して言えば、いくつか改良出来る余地はあるものの、
劇的な高速化が見込めるほどの効果は得ることは難しいのではないか、
というのが今のところの印象。
 
引用:
コードは出来上がったのですが、下記のテストデータのような
総ページ数30ページほどのファイル作成でも、6秒ほどかかります

一番時間が掛かっているのは恐らく「 Word の起動」か
「 PDF ファイルへの出力」なのではないかと。
 
引用:
ページ数分の「ページ区切りの挿入」を繰り返していることが
最大の原因だとは思うんですが

改ページの挿入に関しては、他に書きようがないでしょう。
 
引用:
しおりデータの入力はExcelで行い、Wordでしおりデータを元に
見出しタイトルを作成し、しおりを付けたいpdfファイルと
同ページ数の白紙のpdfファイルに変換して、出来上がった
しおり付きファイルに対して、元ファイルのページを置換

引用:
ツリー状にしたしおりを作成

引用:
.Style = objWordDoc.Styles("見出し " & objWS.Range("B" & i).Value)

ここに関しては、スタイルの設定(に伴うアウトラインレベルの設定)を行なうより、
アウトラインレベルの設定(のみ)を実行するようにした方が僅かに速くなるはず。
(最終的に Word で生成されたページを使用しないなら、フォント等の書式まで
設定する必要はない)
 
(標準モジュール)
--------------------------------------------------------------------
Sub subCreatePdfByWord()
On Error GoTo Err_subCreatePdfByWord
     
    Dim objWord As Word.Application
    Dim objWordDoc As Word.Document
    Dim objWordParagraph As Word.Paragraph
    Dim objWordRange As Word.Range
     
    Dim i As Long, lngLastRow As Long
    Dim lngInsertPage As Long, lngPreviousPage As Long
     
    Dim objWS As Excel.Worksheet
    Dim varArray As Variant
     
    Dim strFolderPath As String
     
    Set objWS = ThisWorkbook.Worksheets("しおり作成")
    lngLastRow = objWS.Range("A" & objWS.Rows.Count).End(xlUp).Row
     
    If lngLastRow < 2 Then
        MsgBox "ブックマーク情報がありません。", vbExclamation, "設定エラー"
        Set objWS = Nothing
        Exit Sub
    End If
     
    varArray = objWS.Range("A2:D" & lngLastRow).Value
 
    Set objWord = New Word.Application
    With objWord
        .Visible = False
        .ScreenUpdating = False
        Set objWordDoc = .Documents.Add
    End With
     
    lngPreviousPage = 1
     
    With objWordDoc
        For i = 1 To lngLastRow - 1
            Set objWordParagraph = .Paragraphs.Last
            Set objWordRange = objWordParagraph.Range
            lngInsertPage = varArray(i, 3) - lngPreviousPage
            Do While lngInsertPage > 0
                objWordRange.InsertBreak Type:=wdPageBreak
                lngInsertPage = lngInsertPage - 1
            Loop
            Set objWordRange = Nothing
            Set objWordParagraph = Nothing
                 
            Set objWordParagraph = .Paragraphs.Last
            objWordParagraph.OutlineLevel = varArray(i, 2)
            Set objWordRange = objWordParagraph.Range
            With objWordRange
                .End = .End - 1
                .Text = varArray(i, 1)
            End With
            Set objWordRange = Nothing
            Set objWordParagraph = Nothing
             
            .Paragraphs.Add
            lngPreviousPage = varArray(i, 3)
             
            If i = (lngLastRow - 1) Then
                Set objWordParagraph = .Paragraphs.Last
                Set objWordRange = objWordParagraph.Range
                lngInsertPage = varArray(1, 4) - lngPreviousPage
                Do While lngInsertPage > 0
                    objWordRange.InsertBreak Type:=wdPageBreak
                    lngInsertPage = lngInsertPage - 1
                Loop
                Set objWordRange = Nothing
                Set objWordParagraph = Nothing
            End If
         
        Next
    End With
         
    objWord.ScreenUpdating = True
         
    strFolderPath = ThisWorkbook.Path & "\"
    'strFolderPath = "D:\WORD_VBA\"
         
    objWordDoc.SaveAs2 strFolderPath & "目次テスト2.docx"
         
    objWordDoc.ExportAsFixedFormat OutputFileName:=strFolderPath & "目次テスト2.pdf", _
                                   ExportFormat:=wdExportFormatPDF, _
                                   CreateBookmarks:=wdExportCreateHeadingBookmarks
                                    
Exit_subCreatePdfByWord:
On Error Resume Next
     
    Set objWordRange = Nothing
    Set objWordParagraph = Nothing
     
    objWordDoc.Close
    Set objWordDoc = Nothing
     
    objWord.Quit
    Set objWord = Nothing
     
    Set objWS = Nothing
     
    Exit Sub
     
Err_subCreatePdfByWord:
     
    Dim strMsg As String
    strMsg = Err.Number & ": " & Err.Description
    Debug.Print strMsg
    MsgBox strMsg, vbCritical, "実行時エラー"
     
    Resume Exit_subCreatePdfByWord
End Sub
--------------------------------------------------------------------

投稿日時: 19/04/09 13:27:34
投稿者: たかみ

アドバイスとコードの提示をいただき、大変ありがとうございます。
 
いただいたコードを試させていただきたいのですが、今日明日、都合でテストできない見込みなものですから、まだ実行してはいないのですが、取り急ぎお礼したいと思いまして書き込みました。
 
テストできましたら改めて参ります。
それまで、少々お時間をください。
 
どうもありがとうございました。

投稿日時: 19/04/10 15:47:30
投稿者: たかみ

本日、時間が出来ましてご提示いただいたコードを実行することができました。
 
30ページ分のデータの時は1秒の短縮でしたが、総ページ数300ページ分でしおりデータは278行分のデータでテストしたところ、10秒弱で終了しました。
データが多ければ多いほどかかる時間が短縮されたことを確認しました。
 
ご指摘の通り、私の書き方ですとフォントまで指定していたので、余計に時間がかかっていたわけですね。
これから、書いてくださったコードについて、調べて内容を理解したいと思います。
 
勉強になりました。
本当にありがとうございました。