[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『その週のメンバー一覧を印刷したい』（kaoru）
毎月のシートが１２ヵ月分あります。
表は１日１表で縦に一月10～最大25日分程度の表が縦にならんでいます。 最初の行のB列に日付が入っており、その行を含めて1表30行です 日付を参照しながら1週間分のA列からE列を横に印刷したいのです。 可能であれば、今週、来週と指定できれば嬉しいのですが 可能でしょうか？ 説明が下手ですいません。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
半角数字で1月～12月のシートがあり、シートのB列の表の日付は 今年の日付がある前提です。
Sub Sample()
Dim 開始日, 終了日, 印刷日
開始日 = CDate(InputBox("開始日を入力してください。", , Format(Date, "YYYY/MM/DD")))
終了日 = CDate(InputBox("終了日を入力してください。", , Format(DateAdd("D", 6, 開始日), "YYYY/MM/DD")))
Dim 印刷シート As Worksheet
Dim シート名 As String
Dim 印刷済み As Boolean
Dim 行 As Long
For 印刷日 = 開始日 To 終了日
シート名 = Month(印刷日) & "月"
On Error Resume Next
Set 印刷シート = Worksheets(シート名)
On Error GoTo 0
If 印刷シート Is Nothing Then
If MsgBox("[" & シート名 & "] シートがありません。" & vbNewLine & "印刷を続けますか?", vbYesNo) = vbNo Then Exit Sub
End If
印刷済み = False
For 行 = 1 To 印刷シート.Cells(Rows.Count, "B").End(xlUp).Row
If IsDate(Cells(行, "B").Value) = True Then
If CDate(Cells(行, "B").Value) = 印刷日 Then
With 印刷シート
.PageSetup.PrintArea = Cells(行, "A").Resize(30, 5).AddressLocal '// 印刷範囲指定
.PageSetup.Orientation = xlLandscape '// 用紙方向指定
.PrintPreview '// 印刷（プレビュー）： 問題なければ .PrintPreview を .PrintOut に変更
End With
印刷済み = True
Exit For
End If
End If
Next
If 印刷済み = False Then
If MsgBox("[" & Format(印刷日, "YYYY/MM/DD") & "] の表がありません", vbYesNo) = vbNo Then Exit Sub
End If
Next
End Sub
マクロの印刷設定の調整は、下記が参考になるかと思います。 http://www.atmarkit.co.jp/ait/articles/1403/25/news038.html http://www.asahi-net.or.jp/~zn3y-ngi/YNxv20011.html
（Mook） 2015/03/09(月) 17:32
ありがとうございます。 マクロ、きちんと動いているようです。 しかし、ご想像の通り、残りは印刷設定です。 できればA4横1枚に全体を縮小して印刷したいのですが 教えて頂いたサイトを見なおして 何とか頑張ってみます。 （そもそも可能なのかなぁ…） 頑張りまーす （kaoru） 2015/03/10(火) 05:17
途中経過ですが… .PageSetup.Zoom = 80 .PageSetup.PaperSize = xlPaperA3 などやってみましたが、 1週分を横に並べて1週を1ページにしたいのですが 1日分1ページが変更できません えぇーと… もう少し、解読してみます （kaoru） 2015/03/10(火) 06:25
> できればA4横1枚に全体を縮小して印刷したいのですが 拡大率は縦横や１ページフィットなどもあるので、そのあたりが使えると思います。
> 1週分を横に並べて1週を1ページにしたいのですが やりたい操作は手動でやろうとした場合、どのような操作になるのでしょうか。
複数の表を横に並べてというと、現在のシート構成ではできないので、印刷用のシートを 用意して、そこにコピーしてから印刷というように、作業の変更が必要な気がします。 （Mook） 2015/03/10(火) 07:57
ながくなってしまいますが、4月6日の週を
「印刷用シート」に手動でコピーし、A３横で
横幅を紙幅に合わせて印刷した場合の物です
Sub Macro1()
Range("A62:C91").Select
Selection.Copy
Sheets("印刷用シート").Select
ActiveSheet.Paste
Sheets("4月").Select
Range("A92:C121").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("印刷用シート").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("4月").Select
Range("A122:C151").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("印刷用シート").Select
Range("G1").Select
ActiveSheet.Paste
Sheets("4月").Select
Range("A152:C211").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("印刷用シート").Select
Range("J1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
End Sub
よろしくお願いします。
（kaoru） 2015/03/10(火) 13:21
まぁわかるといえばわかるのですが、言葉でも説明が欲しいでしょうか。 一週間といっていますが、マクロは４日分のようなので、そこはコード上は定数にしました。
一応のサンプルですので、細かい調整は試行錯誤してみてください。 大丈夫とは思いますが、標準モジュールに置く前提です。
Option Explicit
'//------------------------------------------ Const 印刷シート名 = "印刷シート" '//【設定】 Const 印刷日数 = 6 '//【設定】 印刷シートのデータ数
'//------------------------------------------ Const データ列数 = 3 '//【設定】 Const データ行数 = 30 '//【設定】
'//------------------------------------------
Sub 期間印刷()
'//------------------------------------------
Dim 開始日 As Date
開始日 = CDate(InputBox("開始日を入力してください。", , Format(Date + ((9 - Weekday(Date)) Mod 7), "YYYY/MM/DD")))
Dim 終了日 As Date
終了日 = CDate(Format(DateAdd("D", 印刷日数 - 1, 開始日), "YYYY/MM/DD"))
If MsgBox(Format(開始日, "YYYY/MM/DD(aaa)") & "～" & Format(終了日, "YYYY/MM/DD(aaa)") & " を印刷しますか?", vbYesNo) = vbNo Then Exit Sub
Dim 印刷日 As Date
Dim 位置 As Long
位置 = 1
For 印刷日 = 開始日 To 終了日
If データ設定(印刷日, 位置) = False Then Exit Sub
Next
If 位置 = 1 Then
MsgBox "印刷するデータがありません"
Exit Sub
End If
印刷実行
End Sub
'//------------------------------------------
Function データ設定(対象日 As Date, ByRef 印刷位置 As Long) As Boolean
'//------------------------------------------
'// 印刷開始位置は A1 を決め打ち
'//------------------------------------------
Dim データシート名 As String
Dim データWS As Worksheet
Dim 印刷WS As Worksheet
Set 印刷WS = Worksheets(印刷シート名)
データシート名 = Month(対象日) & "月"
On Error Resume Next
Set データWS = Worksheets(データシート名)
On Error GoTo 0
If データWS Is Nothing Then
If MsgBox("[" & データシート名 & "] シートがありません。" & vbNewLine & "印刷を続けますか?", vbYesNo) = vbNo Then
データ設定 = False
Else
データ設定 = True
End If
Exit Function
End If
Dim 行 As Long
For 行 = 1 To データWS.Cells(Rows.Count, "B").End(xlUp).Row
If IsDate(データWS.Cells(行, "B").Value) = True Then
If CDate(データWS.Cells(行, "B").Value) = 対象日 Then
If 印刷位置 = 1 Then
印刷WS.Range("A1").Resize(データ行数, データ列数 * 印刷日数).ClearContents
End If
データWS.Cells(行, "A").Resize(データ行数, データ列数).Copy 印刷WS.Range("A1").Offset(0, (印刷位置 - 1) * データ列数).Resize(データ行数, データ列数)
印刷位置 = 印刷位置 + 1
データ設定 = True
Exit Function
End If
End If
Next
If MsgBox("[" & Format(対象日, "YYYY/MM/DD(aaa)") & "] の表がありません" & vbNewLine & "印刷を続けますか?", vbYesNo, vbYesNo) = vbNo Then
データ設定 = False
Else
データ設定 = True
End If
End Function
'//------------------------------------------
Private Sub 印刷実行()
'//------------------------------------------
Const 等倍印刷 = False '//【設定】True ・・・ 等倍 ／ False ・・・ １ページ印刷
Dim 印刷WS As Worksheet
Set 印刷WS = Worksheets(印刷シート名)
'// 印刷設定
Application.PrintCommunication = False '// EXCEL 2010 以降のみ
With 印刷WS.PageSetup
.PrintArea = Range("A1").Resize(データ行数, データ列数 * 印刷日数).AddressLocal
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintComments = xlPrintNoComments
.Orientation = xlLandscape '// 印刷用紙 横指定
.PaperSize = xlPaperA3 '// A3 ？
If 等倍印刷 = True Then
.Zoom = 100
Else '// 全体を１ページに印刷
.FitToPagesTall = 1
.FitToPagesWide = 1
End If
.PrintErrors = xlPrintErrorsDisplayed
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
Application.PrintCommunication = True
印刷WS.PrintPreview
' 印刷WS.PrintOut Copies:=1 '// 印刷実行
End Sub
（Mook） 2015/03/10(火) 15:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.