Word VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム

7 / 45 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【798】Re:使いかけラベルシートに差込印刷

マナ - 15/2/16(月) 22:52 -


	引用なし

	パスワード

最初考えてたより、てこずっちゃいました。

Sub 使いかけラベルシートで差込印刷()
　　Dim doc As Document
　　Dim i As Long
　　Dim t As Long, n As Long
　　Dim n1 As Long, n2 As Long
　　Dim msg As String
　　Dim p As Long
　　Dim c As Cell
　　Const cnt As Long = 8　 'ラベル数／シート
　　
　　Set doc = MacroContainer
　　
　　With doc.MailMerge
　　　　With .DataSource
　　　　　　'使用済み枚数（空レコード数）の計算
　　　　　　.ActiveRecord = wdFirstDataSourceRecord
　　　　　　For i = 1 To cnt - 1
　　　　　　　　If .Included Then n1 = n1 + 1
　　　　　　　　.ActiveRecord = wdNextDataSourceRecord
　　　　　　Next
　　　　　　
　　　　　　'差込レコード数の計算
　　　　　　.ActiveRecord = wdLastRecord
　　　　　　t = .ActiveRecord
　　　　　　
　　　　　　.ActiveRecord = wdFirstRecord
　　　　　　
　　　　　　n = 1

　　　　　　Do Until .ActiveRecord = t
　　　　　　　　 .ActiveRecord = wdNextRecord
　　　　　　　　n = n + 1
　　　　　　Loop
　　　　　　
　　　　End With
　　　　
　　　　msg = "シートの" & n1 + 1 & "枚目から" & n - n1 & "枚印刷します"
　　　　If MsgBox(msg, vbOKCancel) <> vbOK Then Exit Sub

　　　　'差込文書作成
　　　　.Destination = wdSendToNewDocument
　　　　.SuppressBlankLines = False
　　　　.Execute
　　End With
　　
　　'最初のシートの不要ラベルを削除
　　Set c = ActiveDocument.Tables(1).Cell(1, 1)
　　For i = 1 To n1
　　　　Do While c.Range.Words.Count = 1
　　　　　　Set c = c.Next
　　　　Loop
　　　　c.Range.Text = ""
　　　　Set c = c.Next
　　Next
　
　　'最終シートの不要ラベルを削除
　　p = ActiveDocument.Range.Information(wdNumberOfPagesInDocument)
　　n2 = cnt - (n Mod cnt)

　　With ActiveDocument.Tables(p)
　　　　Set c = .Cell(.Rows.Count, .Columns.Count)
　　End With
　　If n2 < cnt Then
　　　　For i = 1 To n2
　　　　　　Do While c.Range.Words.Count = 1
　　　　　　　　Set c = c.Previous
　　　　　　Loop
　　　　　　c.Range.Text = ""
　　　　　　Set c = c.Previous
　　　　Next
　　End If
　　
End Sub