第15回「ExcelをWordに貼り付けるVBAマクロ」

コマンド単位の作業は、テキストファイルがいいです。

さて、第15回のお題は「ExcelをWordに貼り付けるVBAマクロ」です。

第14回のお題「Excelの取り消し線を取り除いてテキストに貼り付ける」で
Excelの複数シートをWordに貼り付ける作業を自動化します。

※Visual Basic Editor→ツール→参照設定→Microsoft Word Object Libraryにチェックする
Option Explicit
Sub ExceltoWord()

Dim ObjWord As Word.Application
Dim WordDoc As Object

Set ObjWord = CreateObject("Word.Application")
ObjWord.Application.Visible = True

Set WordDoc = ObjWord.Application.Documents.Add

WordDoc.ActiveWindow.Selection.TypeText Text::="■■■Sheet1■■■" & vbCrLf
MaxRow = Worksheet("Sheet1").cells(Rows.Count,20).End(xlUp).Row
Worksheets("Sheet1").Range("T5:T"&MaxRow).Copy
WordDoc.ActiveWindow.Selection.TypeText Text::="■■■Sheet2■■■" & vbCrLf
Worksheets("Sheet2").Range("A1:A10").Copy
WordDoc.ActiveWindow.Selection.Paste

'取り消し線削除
ObjWord.Selection.Find.Text= ""
ObjWord.Selection.Find.Font.StrikeThrough = True
ObjWord.Selection.Find.Replacement.Text = ""
ObjWord.Selection.Find.Forward = TRUE
ObjWord.Selection.Find.Wrap= wdFindContinue
ObjWord.Selection.Find.Execute ,,,,,,,,,,wdReplaceAll

'txtで保存
WordDoc.SaveAs2 Filename:="test.txt", FileFormat:=wdFormatText, InsertLineBreaks:=True
ObjWord.Quit

Set WordDoc = Nothing
Set ObjWord = Nothing

Application.CutCopyMode = False

End Sub

※MaxRowの20はTを表しています。
自動化できるところは自動化して、シンプルにできるところはシンプルにするがいいです。。