フォームのチエックボックスにチエックを入れるた行のみ印刷出来るマクロ

質問

エクセル97で仮に下記のような表を作成しています
一番左の列にチエックボックスを並べて、印刷したい行のみチエックを入れると、上の標題とチエックした行のみ印刷したいのですが、そんなマクロのボタンを作成したいのですがご教授お願いします
　　Ａ　Ｂ　Ｃ　Ｄ　Ｅ
１　　　○○○表
２　□　あ　い　う　え
３　□　え　お　あ　え
４　□　い　え　お　あ
５　□　か　き　く　け

回答No.9

nishi6 · ベストアンサー

最初の方法でうまくいったBookと２つ目の方法を行うBookは別にします。
別にしたほうが混乱がないはずです。

２つ目の方法を行うBookの、データの入っているシートのＡ列にコントロールツールボックスのチェックボックスを貼りつけます。１行に１つ貼り付けるはずです。
また、コントロールツールボックスからコマンドボタンを配置します。

２つ目の方法を行うBookのVBAのコード部分はない状態にして下さい。
チェックボックスを配置するシートのコードウインドウに、#7のコードをコピーして貼りつけます。
　　チェックボックスがSheet1に配置してあれば、Sheet1のコードウインドウに
　　貼りつけます。Sheet1のコードウインドウの出し方は、表示→プロジェクト
　　エクスプローラでプロジェクトエクスプローラを出して、Sheet1をダブルク
　　リックします。

Const Col1 = "B" '印刷する開始列
Const Col9 = "E" '印刷する最終列

Private Sub CommandButton1_Click()
　　：
　　：
End Sub

＞.Range(Col1 & "1:" & Col9 & "1").Copy Destination:=ws2.Range(Col1 & "1")が黄色になる。
最初の方法がうまくいって、２つ目がここで止まるのは考えられませんが、最初の方法を試したBookと何か違っていませんか。
１行目がセル結合されていると起きる可能性がありますが・・・その場合は、
　　Const Col1 = "B" '印刷する開始列
　　Const Col9 = "E" '印刷する最終列
を実状にあうように修正してみてください。これは先頭行の書き込みです。（この行をＸ行とします）
また、
'.Range(Col1 & "1:" & Col9 & "1").Copy Destination:=ws2.Range(Col1 & "1")
と、この行の前に『'』（Shiftキーを押しながら7のキー）を入力して実行してみて下さい。この行を実行をしないようにするわけです。

これで動けば、Ｘ行の下に次の１行を追加してみます。
　　.Rows("1:1").Copy Destination:=ws2.Rows("1")
とすれば、結合セルがあってもコピーします。

＞シートは増えていますがチェックボックスのチェックが反映されていない？？
上の行でエラーが起きていれば印刷用のシートはまだ作成されていませんので確認はできないはずですが・・・

今もExcel97に貼り付けて実行しましたが、特に問題なく実行できました。
近くに、VBAのわかる人がいらっしゃれば、解決も早いと思いますが・・・

お礼

大変お礼が遅れ申し訳ありませんでした
何回もの補足ご無理をいいました
色々といつも懇切丁寧な回答に非常に助けられます、ありがとうございました

今後ともよろしくお願いします

回答No.8

nishi6

＞最初の方法でsheet2にコピーではなく、同じシートの選択したもののみのsheetが別に作成出来ないでしょうか
別シートを作成し、印刷が終わったら削除しています。

Const Col1 = "B" '印刷(コピー)する開始列
Const Col9 = "E" '印刷(コピー)する最終列

Sub CheckRowsPrint()
　　Dim ws As Worksheet
　　Dim ws2 As Worksheet '印刷用シート2
　　Dim rw1 As Long, rw2 As Long '行カウンタ

　　Set ws = ActiveSheet
　　Application.ScreenUpdating = False

　　Worksheets.Add.Move After:=Worksheets(ws.Name)
　　Set ws2 = ActiveSheet
　　With ws
　　　　'表題のコピー
　　　　ws2.Select: ws2.Cells.Clear: rw2 = 1
　　　　.Select: ActiveCell.Activate
　　　　.Range(Col1 & "1:" & Col9 & "1").Copy Destination:=ws2.Range(Col1 & "1")
　　　　'データ行のコピー
　　　　For rw1 = 2 To .Range("G65536").End(xlUp).Row
　　　　　　If .Range("G" & rw1) = True Then
　　　　　　　　rw2 = rw2 + 1 'チェックボックスがチェックされていればコピー
　　　　　　　　.Range(Col1 & rw1 & ":" & Col9 & rw1).Copy _
　　　　　　　　　　　　　　Destination:=ws2.Range(Col1 & rw2)
　　　　　　End If
　　　　Next
　　End With
　　Application.ScreenUpdating = True

　　'今はプレビュー
　　ws2.PrintPreview 'ws2.PrintOut

　　Application.DisplayAlerts = False
　　ws2.Delete
　　Application.DisplayAlerts = True
End Sub

＞CommandButton1を押すと何も動きがありません？
＞チェックボックスが□のままなので、・・・四隅に□が出るだけになります？
これはVisual Basic がデザインモードだからでしょう。
Visual Basicのツールバーの三角定規と鉛筆のようなアイコンが押された状態がデザインモードです。
再度押せば、解除され、コントロールが操作できるようになるでしょう。一旦保存して開きなおしてもデザインモードは解除されたはずです。

補足

度々の補足大変申し訳ありません
もう少し教えてください
・最初の方法は出来ました、大変ありがとうございました

・コマンドボタンの方法は、初歩的なことが分からなくてごめんなさい、動作できるようになりました
ただ、ボタンを押すとデバックで下のところが黄色になっています？？
.Range(Col1 & "1:" & Col9 & "1").Copy Destination:=ws2.Range(Col1 & "1")
それと、シートは増えていますがチェックボックスのチエックが反映されていない？？

何回も申し訳ありません
よろしくお願いします

回答No.7

nishi6

＞改ページプレビューの画面で終了してしまいます？
いちいち印刷すると大変なので、意識的にプレビューにしています。
ws2.PrintPreview → ws2.PrintOut
に変更すると印刷します。今回もそうしています。印刷するときは変更して下さい。

コントロールツールボックスのチェックボックスを使った方法です。
新しいコントロールですし、フォームのコントロールより（ある意味）使いやすい事が多いです。

表示→ツールバー→Visual Basic Editor でVisual Basicのツールバーを表示します。
　→この中のコントロールツールボックスをクリック。
　→コントロールツールボックス内のチェックボックスをクリックしてセルA2をクリック
　→表示されたチェックボックスを選択して右クリック→プロパティを選択
　　→BackColor を白にする
　　→Caption をなし（文字をみんな削除）にする
　　→AutoSize をTrueにする
　　　　チェックボックスは選択状態だと思いますが、四隅の四角が完全に２行目に入るようにします。
　　初めて登録したなら、(オブジェクト名)がCheckBox1になっているはずです。
　　１行はチェックボックスが入るくらいの行高が必要です。
　→2行目に作ったチェックボックスをコピー
　→A3に貼り付け。以下繰り返し。
　　　　CheckBoxＸ(Ｘは番号)が順番に作られていく事が重要です。
　　　　10個くらい作ったら、Shiftキーを使って複数個選んでコピー＆ペーストができます。
　　　　どの位の行数を操作されるかわかりませんが、チェックボックスを無尽蔵に貼り付けはできないでしょう。

　→コントロールツールボックスからコマンドボタンをクリックしてシート上に１つボタンを作る。
　→作ったコマンドボタンをダブルクリック
　→Private Sub CommandButton1_Click()

　　End Sub
　　　が表示されるので、下のコードを貼り付ける。
　→シートに戻り、Visual Basic のデザインモードを終了します。
　　これで動かす事ができるはずです。(Excel97で確認)

Const Col1 = "B" '印刷する開始列
Const Col9 = "E" '印刷する最終列

Private Sub CommandButton1_Click()
　　Dim ws As Worksheet
　　Dim obj As OLEObject
　　Dim ws2 As Worksheet '印刷用シート2
　　Dim rw1 As Long, rw2 As Long '行カウンタ

　　Set ws = ActiveSheet
　　Application.ScreenUpdating = False

　　Worksheets.Add.Move After:=Worksheets(ws.Name)
　　Set ws2 = ActiveSheet: rw2 = 1
　　With ws
　　　　.Select: ActiveCell.Activate
　　　　.Range(Col1 & "1:" & Col9 & "1").Copy Destination:=ws2.Range(Col1 & "1")
　　　　For Each obj In .OLEObjects
　　　　　　If obj.Name Like "CheckBox*" Then
　　　　　　　　If obj.Object.Value = True Then
　　　　　　　　　　rw1 = .Shapes(obj.Name).TopLeftCell.Row
　　　　　　　　　　rw2 = rw2 + 1 'チェックボックスがチェックされていればコピー
　　　　　　　　　　.Range(Col1 & rw1 & ":" & Col9 & rw1).Copy _
　　　　　　　　　　　　　　　　Destination:=ws2.Range(Col1 & rw2)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
　　Application.ScreenUpdating = True

　　'今はプレビュー
　　ws2.PrintPreview 'ws2.PrintOut

　　Application.DisplayAlerts = False
　　ws2.Delete
　　Application.DisplayAlerts = True
End Sub

補足

度々の補足を書いて申し訳有りません
最初の方法は出来ました大変有り難うございます
もう少し教えてもらえないでしょうか
・最初の方法でsheet2にコピーではなく、同じシートの選択したもののみのsheetが別に作成出来ないでしょうか

・コントロールツールボックスの方ですが、丁寧な回答有り難うございます、最後まで出来たのですが、CommandButton1を押すと何も動きがありません？
チェックボックスが□のままなので、動作しないのかと思い□をクリックするとレが出ません？四隅に□が出るだけになります？
いつも、初心者の補足になって大変お手数をお掛けしますが、もう少し教えてください
よろしくお願いします

回答No.6

nishi6

表示→ツールバー→フォーム のチェックボックスを使った例です。質問のようにA列に配置し、リンクするセルをG列にしてあります。
印刷用のSheet2にチェックした行をコピーします。どの列をコピーするかは、Col1、Col9にセットします。
フォームのコマンドボタンに、CheckRowsPrintを割り当てます。CheckRowsPrintは標準モジュールに貼り付け。

Const Col1 = "B" '印刷(コピー)する開始列
Const Col9 = "E" '印刷(コピー)する最終列

Sub CheckRowsPrint()
　　Dim ws2 As Worksheet '印刷用シート2
　　Dim rw1 As Long, rw2 As Long '行カウンタ
　　Set ws2 = Worksheets("Sheet2")

　　Application.ScreenUpdating = False

　　With Worksheets("Sheet1")
　　　　'表題のコピー
　　　　ws2.Select: ws2.Cells.Clear: rw2 = 1
　　　　.Select: ActiveCell.Activate
　　　　.Range(Col1 & "1:" & Col9 & "1").Copy Destination:=ws2.Range(Col1 & "1")
　　　　'データ行のコピー
　　　　For rw1 = 2 To .Range("G65536").End(xlUp).Row
　　　　　　If .Range("G" & rw1) = True Then
　　　　　　　　rw2 = rw2 + 1 'チェックボックスがチェックされていればコピー
　　　　　　　　.Range(Col1 & rw1 & ":" & Col9 & rw1).Copy _
　　　　　　　　　　　　　　Destination:=ws2.Range(Col1 & rw2)
　　　　　　End If
　　　　Next
　　End With
　　Application.ScreenUpdating = True

　　'今はプレビュー
　　ws2.PrintPreview 'ws2.PrintOut
End Sub

フォームのチェックボックスはその個数分リンクするセルを設定する必要があるでしょう。
コントロールツールボックスのチェックボックスなら、2行目から順に貼り付けていくだけで、この場合はほとんどコントロール配列のように使えます。チェックボックスのコントロールとしての性質と、図形としてのTopLeftCellで位置を自動的に特定できます。

コントロールツールボックスのコマンドボタンのイベントです。Sheet1のコードウインドウに貼り付け。

Const Col1 = "B" '印刷する開始列
Const Col9 = "E" '印刷する最終列

Private Sub CommandButton1_Click()
　　Dim obj As OLEObject
　　Dim ws2 As Worksheet '印刷用シート2
　　Dim rw1 As Long, rw2 As Long '行カウンタ
　　Set ws2 = Worksheets("Sheet2")

　　Application.ScreenUpdating = False

　　ws2.Select: ws2.Cells.Clear: rw2 = 1
　　With Worksheets("Sheet1")
　　　　.Select: ActiveCell.Activate
　　　　.Range(Col1 & "1:" & Col9 & "1").Copy Destination:=ws2.Range(Col1 & "1")
　　　　For Each obj In .OLEObjects
　　　　　　If obj.Name Like "CheckBox*" Then
　　　　　　　　If obj.Object.Value = True Then
　　　　　　　　　　rw1 = .Shapes(obj.Name).TopLeftCell.Row
　　　　　　　　　　rw2 = rw2 + 1 'チェックボックスがチェックされていればコピー
　　　　　　　　　　.Range(Col1 & rw1 & ":" & Col9 & rw1).Copy _
　　　　　　　　　　　　　　　　　　Destination:=ws2.Range(Col1 & rw2)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
　　Application.ScreenUpdating = True

　　'今はプレビュー
　　ws2.PrintPreview 'ws2.PrintOut
End Sub

補足

いつもお世話になっています。もう少しご教授お願いします
最初の設定ですると、印刷しなくて改ページプレビューの画面で終了してしまいます？sheet2にはコピーされていました、途中はsheet2にコピーではなく任意のsheetで最後にはそれはなくてもいいのですが、そんなことが出来ますでしょうか
また、次の説明のご指摘のようにリンクさせるのが大変です、ご説明の下記の内容がやったことがなく分かりません
コントロールツールボックスのチェックボックスなら、2行目から順に貼り付けていくだけで、この場合はほとんどコントロール配列のように使えます。チェックボックスのコントロールとしての性質と、図形としてのTopLeftCellで位置を自動的に特定できます。

コントロールツールボックスのコマンドボタンのイベントです。Sheet1のコードウインドウに貼り付け。

ご教授お願いします

回答No.5

imogasi

私の誤解であればお許し下さい。
質問ではワークシートのA列（の位置）に、チェックボックスを行の数だけ貼りつける様にわたしは解釈しますが、既出ご解答例では、チェックボックスの値（True/False)を聞くところが出てきていません。セルの上下左右罫線をかこんで、四角を作り、１を入れる例（B方式）に変わっていませんでしょうか。
VBと違いVBAでは「コントロール配列」が使えないので、私も考えましたが、チェックボックスの数だけ判別コーディング行が必要で、スマートに出来ず、お手上げでした。
チェックボックスを使わず、上記B方式で設計するのが、
後のVBAコーディングが簡単です。
その時１行ずつ空白行を入れ、上の四角と下の四角が少し
離れてかけるようにすれば良いと思います。
すればIf　Cells(i,1)="1"　Then
　　　Range(Cells(i,2),Cells(i,10)）を別シートに移す　
　　　EndIf
を行数分ForNextででも繰り返し、終わったところでPrintoutすれば良い。PrintOutは毎回通る（実行する）ごとに改ページするのでRange(Cells(i,2),Cellsi,10)）．PrintOutは不可。

お礼

大変お礼が遅れ申し訳ありませんでした
回答参考になりました
大変ありがとうございました

今後ともよろしくお願いします

回答No.4

BlueRay

もう１パターンです。どちらでも結果は同じです。
やりやすい方を選んでやってみてください。

解説：フラグの所に1が入っているものが印刷対象となります。
0は印刷されません。フラグ部分にスペースが入ると終わります。
動作：元となるシートをコピーで作成して、フラグが0のものを
削除した後に印刷をしています。

あくまでサンプルなのでご自分でわかりやすいように
＆表にあったコーディングへと変更してください。

例題：
　　　Ａ　　Ｂ　　Ｃ　　Ｄ　　Ｅ
１　　　　　　　○○○表
２　フラグ
３　　1　　　あ　　い　　う　　え
４　　1　　　え　　お　　あ　　え
５　　0　　　い　　え　　お　　あ
６　　1　　　か　　き　　く　　け

'********** ここから **********
Sub SelectPrint2()
　　Dim iCnt

　　'警告メッセージ非表示
　　Application.DisplayAlerts = False
　　'印刷用シートを元表よりコピー
　　Sheets("○○○表").Copy after:=Sheets(1)
　　Sheets(2).Name = "印刷"
　　'行カウンタ
　　iCnt = 3

　　With Sheets("印刷")
　　　　Do
　　　　　　'フラグチェック
　　　　　　Select Case .Cells(iCnt, 1).Text
　　　　　　　　Case "0"
　　　　　　　　　　'未印刷行を削除
　　　　　　　　　　.Range("" & iCnt & ":" & iCnt & "").Delete
　　　　　　　　Case "1"
　　　　　　　　　　'次行（印刷）
　　　　　　　　　　iCnt = iCnt + 1
　　　　　　　　Case Else
　　　　　　　　　　Exit Do
　　　　　　End Select
　　　　Loop
　　End With

　　'印刷
　　Sheets("印刷").PrintOut
　　'印刷用シート削除
　　Sheets("印刷").Delete
　　'警告メッセージ表示
　　Application.DisplayAlerts = True
End Sub
'********** ここまで **********

お礼

大変お礼が遅れ申し訳ありませんでした
何回もの補足ご無理をいいました
懇切丁寧な回答大変参考になりました
ありがとうございました

今後ともよろしくお願いします

回答No.3

BlueRay

解説：フラグの所に1が入っているものが印刷対象となります。
0は印刷されません。フラグ部分にスペースが入ると終わります。

あくまでサンプルなのでご自分でわかりやすいように
＆表にあったコーディングへと変更してください。

例題：
　　　Ａ　　Ｂ　　Ｃ　　Ｄ　　Ｅ
１　　　　　　　○○○表
２　フラグ
３　　1　　　あ　　い　　う　　え
４　　1　　　え　　お　　あ　　え
５　　0　　　い　　え　　お　　あ
６　　1　　　か　　き　　く　　け

'********** ここから **********
Sub SelectPrint()
　　Dim iRow, iCnt

　　'警告メッセージ非表示
　　Application.DisplayAlerts = False
　　'印刷用シート作成
　　Sheets.Add.Name = "印刷"
　　'タイトル＆見出しコピー
　　For i = 1 To 2
　　　　'コピー
　　　　Sheets("○○○表").Range("" & i & ":" & i & "").Copy
　　　　'貼り付け
　　　　Sheets("印刷").Cells(i, 1).Select
　　　　Sheets("印刷").Paste
　　Next

　　'行カウンタ
　　iRow = 3
　　iCnt = 3

　　With Sheets("○○○表")
　　　　Do
　　　　　　'フラグチェック
　　　　　　Select Case .Cells(iRow, 1).Text
　　　　　　　　Case "0"
　　　　　　　　　　'何もしない
　　　　　　　　　　DoEvents
　　　　　　　　Case "1"
　　　　　　　　　　'コピー
　　　　　　　　　　.Range("" & iRow & ":" & iRow & "").Copy
　　　　　　　　　　'貼り付け
　　　　　　　　　　Sheets("印刷").Cells(iCnt, 1).Select
　　　　　　　　　　Sheets("印刷").Paste
　　　　　　　　　　'次行（印刷）
　　　　　　　　　　iCnt = iCnt + 1
　　　　　　　　Case Else
　　　　　　　　　　Exit Do
　　　　　　End Select
　　　　　　'次行（元データ）
　　　　　　iRow = iRow + 1
　　　　Loop
　　End With

　　'印刷
　　Sheets("印刷").PrintOut

　　'印刷用シート削除
　　Sheets("印刷").Delete
　　'警告メッセージ表示
　　Application.DisplayAlerts = True
End Sub
'********** ここまで **********

回答No.2

BlueRay

例：

○別シートへコピー
１．コピーしたいセルを選択して、コピー
　Range("1:1").Select　　---　1列目をコピー
　Selection.Copy
２．貼り付けしたい開始位置を選択して、ペースト
　Range("A5").Select　　---　A5へ貼り付け
　ActiveSheet.Paste

○終わりまで繰り返す。
１．For～Next
　For i = 0 To 9
　　'コピー処理
　Next
２．Do～Loop
　Do
　　'コピー処理

　　'終了チェック
　Loop

ループの終了方法は、チェックボックスを並べるとかセルにフラグを立てる
とかあるので、それぞれによって条件判定が変わります。

補足

度々の回答有り難うございます

すいません、まだマクロのことは初心者です

お手数をお掛けしますが最初からのマクロ例をご教授お願いできないでしょうか

よろしくお願いします

回答No.1

BlueRay

例えば、チェックの入った行だけを抽出して別シートに
コピーして印刷するようなマクロではどうですか？

例：
Ｘ表・・・上の表
Ｙ表・・・印刷用の表

マクロの流れ
１．Ｙ表（シート）をブックへ追加する。
２．Ｘ表Ａ列のチェックボックスにチェックが入っていればチェックの
　入っている行をＹ表にコピーする。
３．Ｘ表Ａ列の終わりまで繰り返す。
４．Ｙ表を印刷する。
５．Ｙ表（シート）を削除する。

補足

早速の回答有り難うございます
もう少し教えてもらえないでしょうか

２．Ｘ表Ａ列のチェックボックスにチェックが入っていればチェックの
　入っている行をＹ表にコピーする。
３．Ｘ表Ａ列の終わりまで繰り返す。

この部分のマクロはどのようにすればよいのか教えてもらえないでしょうか