差し込み印刷－１－

異世界転生したらプログラミングスキル初級で使えないので放逐されたエルベです。事務員として活躍してるはずです。うぅ・・・。

えーっとですね。担当者３０人くらいそれぞれ顧客約１００人にDM発送したい、と。約３０００通です。さすがのエルベさんも今回はもうダメかと思いました。
A4両面印刷したＤＭ３種類と担当者の名前入りの挨拶状と封筒を印刷します。
与えられたもの
発送先リスト（担当者名、顧客住所、顧客名）

挨拶状

↑は【文例】資料送付に添える一筆箋（資料請求された方へ） | 手紙の書き方を参考に私が作った。実際の文章は機密情報？かもしれんから載せない。もっと全体の配置バランス良かった。

なんでパワポで作るんだよ！！！　と発狂しそうになりますが、ぐぐっと堪えて準備します。
交渉スキルが付いてる人はWORDで作り直していいか確認すると良いでしょう。

まず、発送先をコピーしてマクロ用のエクセルを作る。

なんかパワーポイントの制御難しそうなので封筒から作ります。
ワードで差し込み先の封筒を作る。
端折るよ。
封筒の住所が２行になる場所がありますので、封筒下の担当者名はフッターに入れてます。そうしないと改行でずれるからね(；´∀｀)

WORDの差込印刷の設定はやってくれ。わからん人はググってくれ。（他力本願）

※許されるなら横書き推奨。縦書きの場合はハイフンが鬼門なので頑張って・・・

で、差し込み印刷できる人ならわかると思うんだけど、差し込むとセクション区切りがすべてのページに入るんスよ。
更に実際の封筒データには企業ロゴなどのデータが入っており、印刷時めちゃ重くなる。
極力軽くしたい。ワードでやりたいのは

1. 担当者ごとに差し込み
2. セクション区切りをページ区切りに置換
3. 最終ページを削除（↑をすると最後に空ページが発生する）
4. 名前をつけて保存

ですな。後で指定数印刷するマクロも必要そう。

ちなみにこの前にエクセルに住所の長さを追加して、担当者ごと、住所の長さ順で並べ替えた方が良さそうです。２行にする住所のチェックで全件舐めるのきちゅい(；´∀｀)
そこまでマクロにする気にならんので
こうして

こう

あと、シートを追加して、担当者リストを作る。
担当者列をコピーペーしてシート追加して貼り付け→重複の削除
ついでなんで、担当者ごとに何件発送するのかもカウントしておきましょう。
説明用に作ったデータは３名分

ファイルは

• 差込用リスト.xlsm
• 封筒差込.docm

まずアレしておきましょう。ツール→参照設定

できました！！！（SQL文にめちゃくちゃ苦労したけども！！！）

Sub ワード処理()
'ワードの準備
Dim app As Word.Application: Set app = CreateObject("Word.Application")
Dim doc As Word.Document: Set doc = app.Documents.Open("F:\20210606_差込\封筒差込.docm")
app.Visible = True

'担当者情報
Dim i As Integer
Dim 担当者数 As Integer: 担当者数 = Worksheets("担当者").Range("A1").End(xlDown).Row
Dim 担当者: 担当者 = Worksheets("担当者").Range("A1").CurrentRegion

For i = 2 To 担当者数
'差し込み印刷設定
    With doc.MailMerge
        .OpenDataSource Name:=ThisWorkbook.FullName, _
        sqlstatement:="SELECT * FROM [発送先$] WHERE [担当者] LIKE '" & 担当者(i, 1) & "'"
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With
'セクション区切りをページ区切りに置換
    With app.Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^b"
        .Replacement.Text = "^m"
        .Wrap = wdFindContinue
        .MatchFuzzy = False
    End With
'最後のページ削除
    With app.Selection
        .Find.Execute Replace:=wdReplaceAll
        Dim 最終ページ As Integer: 最終ページ = .Information(wdNumberOfPagesInDocument)
        .GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=最終ページ
        .TypeBackspace
    End With
'担当者名で保存
    app.ActiveDocument.SaveAs2 Filename:="F:\20210606_差込\" & Replace(担当者(i, 1), "　", "") & ".docx"
    app.ActiveDocument.Close
Next
'ワード終了
doc.Close (False)
Set doc = Nothing
app.Quit
Set app = Nothing
End Sub

完成したのがこちらです！！*1

ん？

なんで！？

というわけでよくわからんのでフッターの置換を行いました(´；ω；｀)

エクセルの大量のデータから抽出してワードに差し込むマクロ（多分）

Option Explicit
Sub ワード処理()
'ワードの準備
Dim app As Word.Application: Set app = CreateObject("Word.Application")
Dim doc As Word.Document: Set doc = app.Documents.Open("F:\20210606_差込\封筒差込.docm")
app.Visible = True

'担当者情報
Dim i As Integer
Dim 担当者数 As Integer: 担当者数 = Worksheets("担当者").Range("A1").End(xlDown).Row
Dim 担当者: 担当者 = Worksheets("担当者").Range("A1").CurrentRegion

For i = 2 To 担当者数
'差し込み印刷設定
    With doc.MailMerge
        .OpenDataSource Name:=ThisWorkbook.FullName, _
        sqlstatement:="SELECT * FROM [発送先$] WHERE [担当者] LIKE '" & 担当者(i, 1) & "'"
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With
'セクション区切りをページ区切りに置換
    With app.Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^b"
        .Replacement.Text = "^m"
        .Wrap = wdFindContinue
        .MatchFuzzy = False
    End With
'最後のページ削除
    With app.Selection
        .Find.Execute Replace:=wdReplaceAll
        Dim 最終ページ As Integer: 最終ページ = .Information(wdNumberOfPagesInDocument)
        .GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=最終ページ
        .TypeBackspace
    End With
'フッター置換
    With app.ActiveDocument.Sections(1).Footers(1).Range.Find
        .ClearFormatting
        .Text = ChrW(171) & "担当者" & ChrW(187)
        .Replacement.Text = 担当者(i, 1)
        .Execute Replace:=wdReplaceAll
    End With
'担当者名で保存
    app.ActiveDocument.SaveAs2 Filename:="F:\20210606_差込\" & Replace(担当者(i, 1), "　", "") & ".docx"
    app.ActiveDocument.Close
    
Next
'ワード終了
doc.Close (False)
Set doc = Nothing
app.Quit
Set app = Nothing
End Sub

とりあえず封筒データ完成。続く

参考（というかコピペ元か・・・）

• エクセルVBAでWordを操作して文書を操作する準備と最も簡単なプログラム
• トキドキドキンドットコム :: Wordの差し込み印刷をVBAで制御する
• Word VBAで総ページ数・ページ番号を取得する:ワードマクロ・Word VBAの使い方/Selection
• エクセルVBAでワードの文字を検索して置換えたい -エクセル置換表を基- その他（Microsoft Office） | 教えて!goo
• 【VBA】ワードファイルのフッター内で文字列を置換する | あじゅWeb
• MailMerge.OpenDataSource メソッド (Word) | Microsoft Docs

*1:未完成ｗ