助けてください。印刷マクロを

質問

OS:XPSP2,Excel2002で印刷マクロを教えてください。
"入力シ－ト"に顧客管理用で下のようなデ－タが入っています。
　　　　　A列　　　　　B列　　　C列　
２行目：受付番号　　　氏名　　　住所;　・・・・・・S(列)
３行目　８０００１　　　玉田　　　　　　　　　　　　　　　　
　　　　　８０００２　　　山田
　　　　　８０００３　　　上田
　　　　　　・
　　　　　　・
受付番号はすでに85000くらい（不確定）まで入力済みです。
氏名以下をデ－タとして日々入力していき作成し、件数がかなり溜まった(数百件くらい)ときに印刷をするといった仕事です。
マクロを使って、印刷したいデ－タをMsgで”最初の番号を入力”で受付番号を入れて次に同じようにMsgで”印刷最後の番号を入力”で受付番号を入れて、その間のデ－タをA列からS列まで印刷するものです。

回答No.6

Wendy02 · ベストアンサー

こんばんは。Wendy02です。

こちらも読みました。すぐに書き込めなくて、新たな質問を出させてしまい、どうもすみませんでした。日付の範囲をマクロで入れることさえ分かれば、すぐに出来たのでした。

No.2853780 の変形版です。

Sub TestSample3()
　　'----- 印刷範囲 列指定 ---------
　　Const SHNAME As String = "入力シ－ト" '　　<----- シ－ト名指定
　　Const L_COL As Integer = 1 '"A" '　　<------ 印刷範囲の左端列
　　Const R_COL As Integer = 19 '"S" '　　<----- 印刷範囲の右端列
　　Const DATE_COL As Integer = 20 ' "T" '　<----- 印刷データ判定列（日付形式）
　　Const PREV_MODE As Integer = 1 '　　<----- 0 = 直接印刷 /　 1 = プレビュー
　　Const DT_FORMAT As String = "M月D日" '<-----印刷日の書式

　　Dim SearchWd1 As Variant
　　Dim SearchWd2 As Variant
　　Dim c1 As Range
　　Dim c2 As Range
　　Dim rw As Long
　　Dim LastCell As Range
　　Dim myPrintArea As Range
　　Dim myDate As Variant
　　Dim addmsg As String

　　myDate = Date '本日の日付
　　addmsg = Format$(myDate, DT_FORMAT) & "を" & vbCrLf
　　If MsgBox("印刷日は、" & Format$(myDate, DT_FORMAT) & "にしますがよろしいですか？", vbYesNo) = vbNo Then
　　　　Do
　　　　　　Application.SendKeys "{F2}"
　　　　　　Application.SendKeys "{HOME}"
　　　　　　myDate = Application.InputBox(addmsg & "変更してください。", "日付入力", _
　　　　　　Format$(myDate, DT_FORMAT), Type:=2)
　　　　　　If VarType(myDate) = vbBoolean Or myDate = "" Then Exit Sub
　　　　　　If IsDate(myDate) = False Then addmsg = "日付式が違います。" & vbCrLf
　　　　Loop While IsDate(myDate) = False

　　End If

　　　　　　With Worksheets(SHNAME)
　　　　　　　　If WorksheetFunction.CountA(.Range("A1").CurrentRegion) < 2 Then
　　　　　　　　　　MsgBox "データがありません。マクロを終了します", vbInformation: Exit Sub
　　　　　　　　End If

　　　　　　　　SearchWd1 = Application.InputBox("最初の【受付番号】を入力してください。", "番号入力", Type:=2)
　　　　　　　　If VarType(SearchWd1) = vbBoolean Or SearchWd1 = "" Then MsgBox "終了します。": Exit Sub

　　　　　　　　Set c1 = .Columns(L_COL).Find( _
　　　　　　　　What:=SearchWd1, _
　　　　　　　　LookIn:=xlValues, _
　　　　　　　　LookAt:=xlWhole, _
　　　　　　　　SearchOrder:=xlByColumns, _
　　　　　　　　MatchByte:=False)

　　　　　　　　If c1 Is Nothing Then
　　　　　　　　　　MsgBox SearchWd1 & " は、受付番号列からは見当たりません。" & vbCrLf & _
　　　　　　　　　　"終了します。", vbInformation
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　SearchWd2 = Application.InputBox("最後の【受付番号】を入力してください。", "番号入力", Type:=2)
　　　　　　　　If VarType(SearchWd2) = vbBoolean Or SearchWd2 = "" Then MsgBox "終了します。": Exit Sub

　　　　　　　　Set c2 = .Columns(L_COL).Find( _
　　　　　　　　What:=SearchWd2, _
　　　　　　　　LookIn:=xlValues, _
　　　　　　　　LookAt:=xlWhole, _
　　　　　　　　SearchOrder:=xlByColumns, _
　　　　　　　　MatchByte:=False)
　　　　　　　　If c2 Is Nothing Then
　　　　　　　　　　MsgBox SearchWd2 & " は、受付番号列からは見当たりません。" & vbCrLf & _
　　　　　　　　　　"終了します。", vbInformation
　　　　　　　　　　Exit Sub
　　　　　　　　End If

　　　　　　　　Set myPrintArea = .Range(c1, c2.Offset(, R_COL - 1))
　　　　　　　　　　If MsgBox("'" & myPrintArea.Address & "' の受付簿の印刷を開始します。" & _
　　　　　　　　　　　　"印刷日( " & Format(myDate, DT_FORMAT) & " )は、印刷と同時に、" & Chr(DATE_COL + 64) _
　　　　　　　　　　　　& "　列に設定されます。", vbOKCancel) = vbCancel Then
　　　　　　　　　　　　Exit Sub
　　　　　　　　 End If

　　　　　　　　'日付を入力
　　　　　　　　myPrintArea.Columns(DATE_COL).Resize(, 1).NumberFormatLocal = DT_FORMAT
　　　　　　　　myPrintArea.Columns(DATE_COL).Resize(, 1).Value = myDate

　　　　　　　　'"通知書”欄から"証券”欄までは印刷しない
　　　　　　　　.Range("K1:N1").EntireColumn.Hidden = True
　　　　　　　　.PageSetup.PrintArea = myPrintArea.Address
　　　　　　　　If PREV_MODE = 1 Then
　　　　　　　　　　.PrintOut Preview:=True
　　　　　　　　Else
　　　　　　　　　　UserForm2.Show vbModeless
　　　　　　　　　　DoEvents
　　　　　　　　　　.PrintOut Preview:=False

　　　　　　　　　　Unload UserForm2
　　　　　　　　　　MsgBox myDate & " 印刷分を " & myPrintArea.Rows.Count & "件印刷しました。", , "印刷完了"
　　　　　　　　End If
　　　　　　　　.PageSetup.PrintArea = ""

　　　　　　　　'印刷終了後"通知書”欄から"証券”欄まで再度表示
　　　　　　　　.Range("K1:N1").EntireColumn.Hidden = False

　　　　　　End With
　　　　　　Set c1 = Nothing: Set c2 = Nothing
　　　　　　Set myPrintArea = Nothing
End Sub

お礼

Wendy02さん　いつもありがとうございます。そしてお礼が遅くなりすみません。自分のパソコンでは考えていたように出来ましたが、職場へのコピーがまだできていませんので、なんとも言えませんが多分大丈夫だろうと思います。おかしかったときはまたお願いいたします。