ここから本文です

エクセルVBAにて

kk5********さん

2019/12/1307:42:43

エクセルVBAにて

他の方の引用ですが下のコードで
シートが複数ありまして
シートとセルを固定ではなくて任意に指定して印刷するにはどう書き変えればいいでしょうか?
インプットボックスでセルを選択して下さいと表示させたいです。



Sub test()
Dim sh As Worksheet
Dim r As Integer
Application.ScreenUpdating = False
Set sh = Worksheets("Sheet2")
With Worksheets("Sheet1")
For r = 4 To 22
If .Range("M"&r) Then
sh.Range("B4") = .Range("B"&r)
sh.Range("C4") = .Range("D"&r)
sh.PrintPreview
.Range("M"&r) = False
End If
Next r
End With
Application.ScreenUpdating = True
End Sub

閲覧数:
65
回答数:
1

違反報告

ベストアンサーに選ばれた回答

2019/12/1504:44:15

コード内の使用セルから、ワークシートがどの様な表になっているのかを推測しながら作成しました。
汎用性の高い記述に発展させていくには、より広い知識とアイディアが必要になってきますが、そのためのテクニック関連はインターネット上にとても多く存在します。
今回の、選択範囲を求めるテクニックで分り易いサイトを探しました。
Office TANAKA | 選択範囲の操作
http://officetanaka.net/excel/vba/tips/tips111.htm

'---------- ここから回答 / Excel VBA コード ----------
'2つのプロシージャで構成されています。test2 を実行してください。

Option Explicit

Sub test2()

'■■印刷用のワークシート名を直下の行に指定します■■
Const PrintSheetName = "Sheet2" '【シート名を入力】

'印刷用シートであることを注意喚起。
If ActiveSheet.Name = PrintSheetName Then
MsgBox "印刷用シートです!" & vbCrLf & _
"データ作成シートを表示させてください。", _
vbCritical + vbOKOnly, "注意!"
Exit Sub
End If

'範囲選択した後の動作ボタンを配置しておく。
'配置位置は "F2:G3" に合わせる。
Dim Button As Object
Set Button = ActiveSheet.Buttons.Add(range("F2").Left, _
range("F2").Top, _
range("F2:G2").Width, _
range("G2:G3").Height)

'ボタンへの、表示名と実行プロシージャ名を設定。
With Button
.Characters.Text = "選択完了ボタン"
.OnAction = "Execute"
End With

'ユーザーに、シートの確認と範囲指定してもらうための
'メッセージ表示。
Dim msg
msg = "表示中のシートで印刷データを作成します。" & _
vbCrLf & "このシートでよろしいですか?" & vbCrLf _
& vbCrLf & "セル範囲を指定した後、【選択完了" & _
"ボタン】をクリックして下さい。" & vbCrLf & _
"シートが異なっている場合には【キャンセル】を" & _
"クリックしてから、シートを変えてください。"

Dim sheetResult
sheetResult = MsgBox("" & _
msg, vbQuestion + vbOKCancel, "シート内容の確認")

If sheetResult <> vbCancel Then
'印刷用シート名をボタンの背景セルに代入
ActiveSheet.range("F2").Value = PrintSheetName
Else
Button.Delete
End If

'object のメモリー解放
Set Button = Nothing

End Sub

'---------------------------------------------------

' ユーザーのボタンクリックで実行するプロシージャ
Private Sub Execute()

Dim sh As Worksheet
Dim r As Long

'範囲選択したシート名の取得。
Dim sName As String
sName = Selection.Parent.Name

'"F2"セルの内容を変数"PrintSheet"に代入。
Dim PrintSheet
With ActiveSheet
PrintSheet = .range("F2").Value
End With

'選択範囲内に於ける最初と最後のセルの行・列番号を取得。
Dim sRow As Long, sColumn As Long
Dim eRow As Long, eColumn As Long
sRow = Selection(1).Row
sColumn = Selection(1).Column
eRow = Selection(Selection.Count).Row
eColumn = Selection(Selection.Count).Column

'ユーザー宛てのメッセージ内容。
Dim Message As String
Message = "選択したセル範囲は、" & sName & _
" の セル範囲 " & Chr(sColumn + 64) & sRow & _
" ~ " & Chr(eColumn + 64) & eRow & " ですか?" & _
vbCrLf & "違う場合は" & "【いいえ】をクリック" & _
"して選択し直してください。"

'ユーザー宛てに、範囲が正しいかの確認メッセージを出す。
Dim rangeResult As Integer
rangeResult = MsgBox(Message, vbQuestion + vbYesNo, "確認")

'[はい]ボタンがクリックされた場合、ボタンを削除して
'選択範囲に合わせた核心処理を行う。
If rangeResult = vbYes Then

With ActiveSheet
Application.ScreenUpdating = False
Set sh = Worksheets(PrintSheet)

For r = sRow To eRow
If .Cells(r, sColumn) Then
sh.range("B4") = .Cells(r, 2) '2 = B列
sh.range("C4") = .Cells(r, 4) '4 = D列
sh.PrintPreview
Cells(r, sColumn) = False
End If
Next r

.range("F2").ClearContents
.Buttons.Delete
End With
End If

Application.ScreenUpdating = True

End Sub

'************* 回答ここまで *******************


質問内の VBA の元コード に対して何をどうするコードなのかを、可読性が阻害されることを承知しつつも解説しました。再確認の意味で参考にしてみてください。もしかしたら、新たな発見があるかもしれません。

' ------------------質問内のコードの1行ごとの解説----------------

'[Sub~End Sub]で囲んだ範囲をSubプロシージャと呼び、Macroの
'一つの塊を構成する。
Sub test()

'shと呼ぶ、Worksheet(Object)型の変数を使う。
Dim sh As Worksheet

'rと呼ぶ、[-32768 ~ 32767]まで扱える整数型の変数を使う。
Dim r As Integer

'Excelウィンドウ内の表示更新を止める。
Application.ScreenUpdating = False

'空の変数shへ、Sheet2をObjectとして代入する。
'Objectを変数に代入することで実行速度向上を図る。
Set sh = Worksheets("Sheet2")

'[With + Object ~ End With] は、実行の際にObjectを初
'めの一度だけ読み込ませてキャッシュさせ、キャッシュさ
'れたObjectを使い回して様々な操作をする場合に使う。
'実行速度と可読性の向上を目的としたテクニックの一つ。
With Worksheets("Sheet1")

'[For ~ Next]で囲んだ範囲内の行を繰り返し実行する。
'繰り返される回数は、変数rが4からスタートして22にな
'るまでの19回。[Next r]を実行するとrは+1される。
For r = 4 To 22

'[If ~ End If]は、指定された条件に合致したとき
'だけ、[If ~ End If]に囲まれた行を実行する。条
'件に合致しない時は、End If行までジャンプする。
'条件は、[Sheet1のM列の該当セルの値がTrueの時]
If .range("M" & r) Then

'Sheet1のB4セルにSheet2のB列r行の値を代入。
sh.range("B4") = .range("B" & r)

'Sheet1のC4セルにSheet2のD列r行の値を代入。
sh.range("C4") = .range("D" & r)

'Sheet1を対象として印刷プレビューを表示する。
sh.PrintPreview

'Sheet1のM列r行の値を、真偽の[偽]に設定する。
.range("M" & r) = False

'Ifステートメントの終了。
End If

'For~Nextステートメントの終了。
Next r

'Withステートメントの終了。
End With

'Excelウィンドウ内の表示更新を再開する。
Application.ScreenUpdating = True

'Subステートメントの終了。
End Sub
' ----------------------- 解説終了 -----------------------

質問した人からのコメント

2019/12/17 07:23:08

細かく返答していただきありがとうございますm(__)m
非常に分かりやすくて助かりました

あわせて知りたい

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる