VBA Excelで作られたマニュアルをWordに変換する補助ツールを作成

Excelで作成されたマニュアルをWord化したい場合がある。
一旦PDFにしてから読み込んでくる手もあるが、あとで色々と機能を付け足すためにもマクロでやってみたいと思う。

Excelマニュアルは、以下のように文字と画像が交互に配置されているものを想定している。
f:id:t-hom:20151130083901p:plain

このまま交互にWordに張り付ければ良いと考えるかもしれないが、文字はセルに書かれているのに対し、画像はセルとは関係なく浮かんでいるので、見た目ほど簡単ではない。

例えば文字だけ取り出すのは以下のように全セルを走査すれば簡単にできる。

Sub StringPicker()
    For Each r In Range(Cells(1, 1), Cells.SpecialCells(xlCellTypeLastCell))
        If r.Value <> "" Then Debug.Print r.Value
    Next
End Sub

また、画像だけ取り出すのも以下のように全シェイプを走査すれば良い。

Sub PicturePicker()
    Dim s As Shape
    For Each s In ActiveSheet.Shapes
        Debug.Print s.Name
    Next
End Sub

では、交互に並んだ順を崩さずにWordに張り付けるにはどうするか。

まず、文字と画像を段落要素として共通に扱えるようにクラスを作成する。
クラス名はParagraphItemとした。

Private InnerItem
Private InnerTop As Double

Property Get Top() As Double
    Top = InnerTop
End Property

Property Get Self() As ParagraphItem
    Set Self = Me
End Property

Property Get PrintableItem() As String
    If TypeName(Item) = "String" Then
        PrintableItem = Item
    Else
        PrintableItem = Item.Name
    End If
End Property

Property Set Item(obj As Object)
    InnerTop = obj.Top
    If TypeName(obj) = "Range" Then
        Let InnerItem = obj.Value
    ElseIf TypeName(obj) = "Shape" Then
        Set InnerItem = obj
    Else
        Err.Raise 1000, , "ParagraphItemはRangeとShapeのみ格納できます。"
    End If
End Property

Property Get Item() As Variant
    If IsObject(InnerItem) Then
        Set Item = InnerItem
    Else
        Let Item = InnerItem
    End If
End Property

これを使うサンプルコードはこちら。
ItemにRangeかShapeを格納し、共通のプロパティPrintableItemでデバッグプリントしている。

Sub ParagraphPicker()
    Dim C As New Collection
    
    '文字列のピックアップ
    For Each r In Range(Cells(1, 1), Cells.SpecialCells(xlCellTypeLastCell))
        If r.Value <> "" Then
            With New ParagraphItem
                Set .Item = r
                C.Add .Self
            End With
        End If
    Next
    
    '画像のピックアップ
    Dim s As Shape
    For Each s In ActiveSheet.Shapes
        With New ParagraphItem
            Set .Item = s
            C.Add .Self
        End With
    Next
    
    '出力
    Dim p As ParagraphItem
    For Each p In C
        Debug.Print p.PrintableItem
    Next
End Sub

結果は以下のように、文字、画像の順に出力される。

■環境変数の設定方法について
Win+Pauseキーでコントロールパネルのシステムを表示させます。
次に、システムの詳細設定をクリックしてください。
次に環境変数ボタンをクリックします。
次に、ユーザー環境変数グループにある、新規ボタンをクリックします。
最後に、変数名と値を入れて、OKで閉じます。
他の画面もOKで閉じてください。
以上で完了です。
Picture 1
Picture 2
Picture 3
Picture 4

ここで前回のコレクションのソートを登場させる。
ソートのコードはこちらの記事を参照。
thom.hateblo.jp

そして、ソートキー関数(前回記事にて説明)は、次のように用意する。

Function SortByVerticalLocation(V As ParagraphItem) As Double
    SortByVerticalLocation = V.Top
End Function

後は出力前に、CSort C, "SortByVerticalLocation"として呼び出すだけだ。

結果は次のように、Topプロパティで並び替えされている。

■環境変数の設定方法について
Win+Pauseキーでコントロールパネルのシステムを表示させます。
次に、システムの詳細設定をクリックしてください。
Picture 1
次に環境変数ボタンをクリックします。
Picture 2
次に、ユーザー環境変数グループにある、新規ボタンをクリックします。
Picture 3
最後に、変数名と値を入れて、OKで閉じます。
Picture 4
他の画面もOKで閉じてください。
以上で完了です。

Word張り付けの実装

以下が完成したメインコードである。
実行には、Microsoft Word XX.X Object Libraryの参照設定が必要となる。

Sub ParagraphPicker()
    Dim C As New Collection
    
    '文字列のピックアップ
    For Each r In Range(Cells(1, 1), Cells.SpecialCells(xlCellTypeLastCell))
        If r.Value <> "" Then
            With New ParagraphItem
                Set .Item = r
                C.Add .Self
            End With
        End If
    Next
    
    '画像のピックアップ
    Dim s As Shape
    For Each s In ActiveSheet.Shapes
        With New ParagraphItem
            Set .Item = s
            C.Add .Self
        End With
    Next
    
    CSort C, "SortByVerticalLocation"
    
    Dim WD As New Word.Application
    WD.Visible = True
    WD.Documents.Add
    '出力
    Dim p As ParagraphItem
    For Each p In C
        If IsObject(p.Item) Then
            p.Item.Copy
            WD.Selection.Paste
        Else
            WD.Selection.TypeText p.Item
        End If
        WD.Selection.TypeParagraph
    Next
End Sub