マクロでリストの印刷をしたい

質問

教えてください。
「案内状」を宛名を変更しつつ、一括で印刷したいと思っています。
Sheet1 にその「案内状」あり、宛先は空欄になっています。
Sheet2 に宛先名の表があります。Ａ列に連番があり、Ｂ列に名前が５０行あり、Ｃ列の任意の行に○のマークがしてあります。この○のところの宛名をSheet1 の「案内状」の宛先欄に埋め込み、一枚づつ印刷したいと思っています。マクロでこのようなことができないでしょうか。よろしくお願いします。

回答No.2

imogasi · ベストアンサー

＃１と違ってエッセンスのみ記します。
ＶＢＥの画面にＭｏｄｕｌｅ１を挿入し、下記をコーディングする。
Sub testpr()
For i = 1 To 3
If Worksheets("sheet2").Cells(i, 3) = "○" Then
Worksheets("sheet1").Cells(2, 2) = Worksheets("sheet2").Cells(i, 2)
Worksheets("sheet1").Range("a1:d10").PrintOut
End If
Next i
End Sub
そして実行する。（簡単な例で上記をテスト済み。印刷しました。）
貴殿のケースでの手直しは
（１）上記では３行としていますが、５０行なら３－＞５０に直す。またはＣｕｒｒｅｎｔＲｅｇｉｏｎ．Ｃｏｕｎｔなどを使って最終行を掴む。
（２）○はＳｈｅｅｔ２のＣ列に有るとする。
（３）宛名はＳｈｅｅｔ２のＢ列に有るものとする。
（４）Ｓｈｅｅｔ１の案内状の宛名はＢ２すなわちＣｅｌｌｓ（２，２）にあるものと仮定しています。実態に合わせて変えること。
（５）PrintOutで１回通る毎に１ページ印刷して改ページ
してしまうことを上記では覚悟してください。
印刷の設定法の詳細は、マクロの記録を行って真似して
下さい。（用紙のサイズなど。）

お礼

ご回答ありがとうございます。
実験してみたところ、うまく行きました。質問の仕方がまずいのにかかわらず、意図をお汲みいただき感謝いたします。
宛名のセル位置と、印刷範囲、リストの行数の変更のみで完璧に実行できました。後日、締め切り後にポイント発行させていただきたいと思います。

回答No.1

overdoze

以下のモジュールでだいじょぶかと思います。
前提条件は、あなたの条件に加えて、
・Sheet１の宛名が代入されるセルはセル「A1」と仮定
・Ｂ列の名前は最後まで連続していること（つまり途中に空白セルがないこと）
・宛名は「形式選択」の「値」のみペーストしていること
・マクロはSheet2をアクティブの状態で実行する。
・sheet2のリストはすべて1行目からはじまっている（つまり1行目に「番号、名前、チェック」などの表題がはいってない）

＜解説＞
１．変数の設定
２．最初の「Do While Loop」 で名前リストのリスト数を確定しています。
a がカウント変数となってて、Ｂ列（つまり名前の列）を参照しながら空白セルが登場するまで、aを1づつ増やしていきます。
aは名前リストの最後の行の次の空白セルまでカウントしてしまいますので、Loopの次に「a = a - 1」としています。
aの値は次の「For － Next」ループでループの終わりに使ってます。
３．「For Next」でIF構文でリストをチェックしながら、印刷していきます。
If構文で3列目を参照しながら、セルの値が「○」ならその横のセルをコピーしてSheet1の宛名欄にペースト、印刷。
セルの値が「○」じゃなかったら次のセルへ移動。
これをリストの最後（つまり変数aの値）までくりかえします。

ポイントはセル番地の表現方法だと思います。自動マクロで記録すると、セルは

Range("A1")

と表現されますが、

Cells(m, n）

とも表現できます。これは「m」がそのセルの行数、「n」が列数です。
ですからA1のセルは「cells(1, 1)」、B1のセルは「cells（1, 2)」となります。
この方法でセルを表現すると、セル番地に変数が使える為応用が利きます。
ちなみに、シートの表現方法も、
Sheets("シート名")
ではなく
Sheets(1) → 1番目のシート
と表現できます。

ちなみにsheet1の宛名が入るべきセル番地はIF構文の「cells（1, 1)」指定してますので、上記のセルの表現で直して下さい。
また、名前リストが2行目から始まっている場合は
・冒頭の 「a = 1」を「2」に
・For - Next構文の 「For b = 1・・・」を「b = 2」に
してみて下さい。

Sub 印刷()

Dim a As Integer
Dim b As Integer

a = 1

Do While Cells(a, 1) <> ""
a = a + 1
Loop

a = a - 1

For b = 1 To a

If Cells(b, 3) = "○" Then

Cells(b, 2).Select

Selection.Copy

Sheets(1).Select

Cells(1, 1).Select

Selection.PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:= _
False, Transpose:=False

ActiveWindow.SelectedSheets.PrintOut copies:=1

Sheets(2).Select

b = b + 1

End If

Next b

MsgBox "印刷が完了しました。"

End Sub

お礼

早速のご回答、ありがとうございます。
ご丁寧な解説までいただき感謝いたします。ですが当方の知識が乏しく理解できませんでした。ＶＢＥの画面にＭｏｄｕｌｅ１を挿入して、コピー＆ペーストして見ましたが、うまく行きませんでした。印刷が開始されませんでした。