[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『前回の行の追加等』（まいまい）
以前質問しました件で、行の追加ですが、不注意で消してしまいまた（＞＜）(涙）
せっかく時間を割いて色々と助けてくださった方に申し訳ないです......
本当にすみません...
＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
こんばんわ。 まぁそう言う事もあるでしょう。 履歴が残ってたのでアップします。
まずレイアウトですけど、こんな感じで大丈夫でしょうか？
シートモジュールのWorksheet_Changeイベントに貼り付けて下さい。 A3セルに日付を入力すると4行目以降のデータを全て削除して新規に日付データを作成します。 間違っての作り直しを防ぐ為に、A2セルに済と入力していれば起動しません。 祝日に関しては、"祝日"と言う名前のシートのA列に年月日の日付データを入力してると仮定しています。 コメントでは日祝との事ですけど、レイアウトは土曜日も1行になっているので、土日祝日が1行になるようにしています。 土曜日を6行にしたい時はコメントのある部分を6にして下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim cnt As Integer
Dim shPH As Worksheet
If Target.Address <> "$A$3" Then Exit Sub
If Target.Value = "" Then Exit Sub
If Not IsDate(Target.Value) Then Exit Sub
If Range("A2").Value = "済" Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Set shPH = Sheets("祝日")
cnt = 1
Range("A4:A3000").EntireRow.Delete Shift:=xlUp
Range("A3:K3").Borders(xlEdgeTop).LineStyle = xlContinuous
For i = 4 To 2196
Select Case True
Case Weekday(Cells(i - 1, "A").Value, vbMonday) > 5'←この数字を6にすれば土曜も6行になります。
Cells(i, "A").Value = Cells(i - 1, "A").Value + 1
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
Case WorksheetFunction.CountIf(shPH.Range("A:A"), Cells(i - 1, "A").Value) > 0
Cells(i, "A").Value = Cells(i - 1, "A").Value + 1
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
Case cnt = 6
Cells(i, "A").Value = Cells(i - 1, "A").Value + 1
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
cnt = 1
Case Else
Cells(i, "A").Value = Cells(i - 1, "A").Value
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlDot
cnt = cnt + 1
End Select
If Cells(i, "A").Value = DateSerial(Year(Cells(3, "A").Value) + 1, 4, 1) Then
Cells(i, "A").EntireRow.Delete Shift:=xlUp
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
Exit For
End If
Next i
Range("A:A").NumberFormatLocal = "m/d (aaa)"
Set shPH = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
後印刷に関してですが、いくつか質問があります。
1つ目は、印刷は今日と明日の2日分との事ですが、今日は良いとして明日が祝日などで休みの場合はどうなるのでしょう？ 例で言えば、4月1日に印刷する場合は4月1日と2日で宜しいのでしょうか？ 1日～4日までを印刷するのでしょうか？ それとも2日と3日を飛ばして、1日と4日を印刷するのでしょうか？ (この場合は行の非表示の操作がいります)
2つ目は、過去の日付の分を印刷する事は絶対に無いのでしょうか？ 今日の日付の取得はマクロ内だけでも可能なので、特にセルにTODAY関数を入力しておく必要はありませんが、 過去の日付の印刷を行う場合があれば、セルに入力した日付を読み取るか、インプットボックスなどで都度指定するかになります。
3つ目は、レイアウトにはラベルがありませんが実際の表も無いのでしょうか？ もしもあるのでしたら、印刷設定にラベル行の設定も必要になります。
（sy） 2016/03/31(木) 01:00
他の方のコメントもメモ帳に保存しましたが、ご本人に無断で掲載するのもどうかと思うので、保留にしておきます。 （sy） 2016/03/31(木) 01:12
こんなんでしたかね。ちょいと改良。
★やりたいこと
１年分（例えば、2016/4/1～2017/3/31）の日付について、 マクロを実行すると、日付を自動書き込みするようにしたい！
書込み対象シートを「シート名：Sheet1」にする。 （平日は、6行に、土日祝は1行にする。日付は、A列の3行目以降に書き込む）
別シートで「シート名：祝日」を用意する。祝日シートのA列の2行目以降に 「2016/1/1」の形式で書き込む。
日付は2016/4/1ならA列に「4/1(金)」と表示する。
また、印刷エリアを、今日と明日の2日分にしたい。 （下記のマクロでは、B1セルにあるCheckBoxをONにすると、フィルター機能が働いて、「今日から6日後までの7日分」が印刷エリアになるようにしてます。）
同じ日付は「点線」で、日付が変わる境目は「実線」で罫線により区切る。
A1セル=【今日の日付】数式 B1セル=■CheckBox ← フィルターのON,OFFを切り替えるチェックボックス C1セル=■印刷 ← 印刷プレビューボタン K1セル=【日付カウント】数式
★2行目（A～K列）には「半角スペース」が入力されています。 フィルター機能で 2行目にタイトル（何かしらの値）が入っている必要があるため。
|[A] |[B] |[C] |[D]|[E]|[F]|[G]|[H]|[I]|[J]|[K]
[1] |【今日の日付】|■CheckBox|■印刷| | | | | | | |【日付カウント】
[2] | | | | | | | | | | |
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
[3] |4/1 (金) | | | | | | | | | |
[4] |4/1 (金) | | | | | | | | | |
[5] |4/1 (金) | | | | | | | | | |
[6] |4/1 (金) | | | | | | | | | |
[7] |4/1 (金) | | | | | | | | | |
[8] |4/1 (金) | | | | | | | | | |
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
[9] |4/2 (土) | | | | | | | | | |
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
[10]|4/3 (日) | | | | | | | | | |
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
[11]|4/4 (月) | | | | | | | | | |
[12]|4/4 (月) | | | | | | | | | |
[13]|4/4 (月) | | | | | | | | | |
[14]|4/4 (月) | | | | | | | | | |
[15]|4/4 (月) | | | | | | | | | |
[16]|4/4 (月) | | | | | | | | | |
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
To まいまい さん 消しちゃいましたか。メモ帳に残ってましたので再アップします。
ちょっと、やり過ぎてしまいましたが、こんな感じで、どうでしょうか？ ■ファイルをダウンロードできるサイトのUPLを一番下に書きました。
(1)「シート名：祝日」、「シート名：Sheet1」を作成してください。
(2)「シート名：祝日」にデータΑ（*～*間のデータ）を入力してください。
（データTABの区切り位置機能にて取り込んでください。区切り文字は、「|」です。）
C2セルに次の数式を入力し、C列においてC2セルより下のセルへフィルコピー（数式コピー）
=IF(A2="","",TEXT(A2,"aaa"))
祝日シートのC列に、「月、火、水、木、金、土、日」を表示する数式です。
(3)下記の「Macro1」～「Macro5」（●～●間のコード）をModule1にコピペしてください。
(4)「Macro1_日付書き込み」、「Macro2_お好み設定」を続けて実行すると、
「シート名：Sheet1」の「B1セル」にチェックボックスが出現します。
(5)このチェックボックスをチェックONすると、「シート名：Sheet1」のA列の日付のうち、
「今日の日付」、「今日の日付の1日後の日付」、…、「今日の日付の6日後の日付」
を【検索日付】として使用して、フィルターにかけます。
また、フィルターで絞り込まれた範囲が、印刷エリアになるように設定してます。
「シート名：Sheet1」の「D1:J1」セルに、【検索日付】を自動入力します。
(6)「シート名：Sheet1」の「C1:D1セル領域」にある「印刷プレビュー」ボタンを押してください。 (7)チェックボックスをチェックOFFにすると、フィルター機能と印刷エリアが解除されます。
なお、「シート名：Sheet1」の【2行目（A～K列）】は、チェックボックスをチェックOFFにすると 「半角スペース」が入力されます（何か文字が入力されていたら消えます）。 （フィルター機能を使うのに、２行目をタイトル行として使用するため。）
また、 「シート名：Sheet1」の「A1」セルの数式はなくても構いません。 同様に、「シート名：Sheet1」の「K1」セルの数式はなくても構いません。 「K1セルの数式：A列の3行目～5000行目において、日付の種類をカウント」
データΑ：「シート名：祝日」
|[A] |[B]
[1] |日付 |祝日名
[2] |2016/01/01|元日
[3] |2016/01/11|成人の日
[4] |2016/02/11|建国記念の日
[5] |2016/03/20|春分の日
[6] |2016/03/21|振替休日
[7] |2016/04/29|昭和の日
[8] |2016/05/03|憲法記念日
[9] |2016/05/04|みどりの日
[10]|2016/05/05|こどもの日
[11]|2016/07/18|海の日
[12]|2016/08/11|山の日
[13]|2016/09/19|敬老の日
[14]|2016/09/22|秋分の日
[15]|2016/10/10|体育の日
[16]|2016/11/03|文化の日
[17]|2016/11/23|勤労感謝の日
[18]|2016/12/23|天皇誕生日
[19]|2017/01/01|元日
[20]|2017/01/02|振替休日
[21]|2017/01/09|成人の日
[22]|2017/02/11|建国記念の日
[23]|2017/03/20|春分の日
[24]|2017/04/29|昭和の日
[25]|2017/05/03|憲法記念日
[26]|2017/05/04|みどりの日
[27]|2017/05/05|こどもの日
[28]|2017/07/17|海の日
[29]|2017/08/11|山の日
[30]|2017/09/18|敬老の日
[31]|2017/09/23|秋分の日
[32]|2017/10/09|体育の日
[33]|2017/11/03|文化の日
[34]|2017/11/23|勤労感謝の日
[35]|2017/12/23|天皇誕生日
●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●
Option Explicit
Const sh_name1 As String = "Sheet1" '★「日付書き込みシート」
Const sh_name2 As String = "祝日" '★「祝日設定シート」
Const d1 As Date = "2016/4/1" '★ 開始日付
Const d2 As Date = "2017/3/31" '★ 最終日付
Const j1 As Long = 6 '★ 平日なら6行
Const j2 As Long = 1 '★ 土日祝なら1行
Const c1 As Long = 1 '★ 書込み開始列（A列なら1）
Const c2 As Long = 11 '★ 書込み最終列（K列なら11）
Const r1 As Long = 3 '★ 書込み開始行（3行目からなら3）
Sub Macro1_日付書き込み()
Dim days As Long, mx As Long, k As Long, tmp As Date
Dim i As Long, j As Long, p As Long, r As Long
Dim msg1 As String, msg2 As String
Dim a_case As Long, b_case As Long
Dim sh1 As Worksheet, sh2 As Worksheet, sh As Worksheet
'既存シートに次のシートがないとエラー →「インデックスが有効範囲にありません。」
Set sh1 = Sheets(sh_name1): Set sh2 = Sheets("祝日")
'事前チェック その1（開始日付、最終日付）
If d2 < d1 Then
b_case = 1: GoTo step1
End If
days = d2 - d1 + 1
'事前チェック その2（「日付書き込みシート」を初期化していいか確認）
msg1 = " 上記の日付で、日付書き込み処理を開始します。" & vbCrLf & _
"（処理前に、「シート名：" & sh1.Name & "」を初期化します。）" & vbCrLf & _
" よろしいですか？"
msg2 = d1 & " --- " & d2
If MsgBox(msg1, vbOKCancel, msg2) = vbCancel Then
b_case = 2: GoTo step1
End If
'************************************************************************************
'画面更新等をOFFにして、処理を始める
Call 画面更新等OFF
For Each sh In ThisWorkbook.Worksheets
If sh.Name = sh_name1 Then
Application.DisplayAlerts = False: sh.Delete: Application.DisplayAlerts = True
End If
Next
Worksheets.Add after:=Worksheets(Worksheets.Count): ActiveSheet.Name = sh_name1
Set sh1 = Sheets(sh_name1) '作り直したので、設定し直す
'************************************************************************************
'日付の配列（開始日付～最終日付）
ReDim d_array(1 To days) As Date
For i = 1 To days
d_array(i) = d1 + k: k = k + 1
Next i
'************************************************************************************
'祝日の配列（開始日付～最終日付のうち、祝日シートにあるもの）
ReDim Holiday_array(1 To 1) As Date
mx = sh2.Range("A" & Rows.Count).End(xlUp).Row: k = 0
For i = 2 To mx '★2行目から最終行まで（祝日の日付はA列にあるとしている）
If IsDate(sh2.Range("A" & i).Value) Then
tmp = sh2.Range("A" & i).Value
If tmp >= d1 And tmp <= d2 Then
k = k + 1: ReDim Preserve Holiday_array(1 To k): Holiday_array(k) = tmp
End If
End If
Next i
'************************************************************************************
ReDim x(1 To 5000, 1 To 1) As Date '★（適当に設定：5000）セルに書き込む日付の配列
ReDim t1(1 To days) As Long '各々の書式設定開始行を配列に格納
ReDim t2(1 To days) As Long '各々の書式設定最終行を配列に格納
ReDim t3(1 To days) As Long '各々の書式分類ナンバー（土：1、日：2、祝：3、平：4）
k = 0 '初期値
For i = 1 To days
If k > 5000 Then '★（適当に設定：5000）
b_case = 3: GoTo step1
End If
a_case = 4 '初期値（平日なら4）
If Weekday(d_array(i)) = 7 Then a_case = 1 '土曜なら1
If Weekday(d_array(i)) = 1 Then a_case = 2 '日曜なら2
For j = 1 To UBound(Holiday_array)
If Holiday_array(j) = d_array(i) Then a_case = 3 '祝日なら3（土日でも祝日なら3）
Next j
If a_case = 1 Or a_case = 2 Or a_case = 3 Then
For p = 1 To j2
x(k + p, 1) = d_array(i)
Next p
t1(i) = (r1 - 1) + k + 1: t2(i) = (r1 - 1) + k + j2: t3(i) = a_case
k = k + j2 'kを再設定
ElseIf a_case = 4 Then
For r = 1 To j1
x(k + r, 1) = d_array(i)
Next r
t1(i) = (r1 - 1) + k + 1: t2(i) = (r1 - 1) + k + j1: t3(i) = a_case
k = k + j1 'kを再設定
End If
Next i
'************************************************************************************
'「日付書き込みシート」をクリアした後に、セルに日付を書き込む（A列3行目～A列最終行）
With sh1.Range(sh1.Cells(r1, c1), sh1.Cells(k + 2, c1))
.NumberFormatLocal = "m/d (aaa)": .Value = x
End With
sh1.Columns(c1).AutoFit 'A列の幅を自動調整
'************************************************************************************
'書式設定（A列3行目～K列最終行）
With sh1.Range(sh1.Cells(r1, c1), sh1.Cells(k + 2, c2))
.Borders(xlEdgeTop).Weight = xlMedium '（上辺の線） 中太線
.Borders(xlInsideHorizontal).Weight = xlHairline '（内側の水平線）極細線
End With
For i = 1 To days
With sh1.Range(sh1.Cells(t1(i), c1), sh1.Cells(t2(i), c2))
.Borders(xlEdgeBottom).Weight = xlMedium '（下辺の線） 中太線
Select Case t3(i)
Case 1: .Interior.Color = RGB(197, 217, 241) '土曜なら、青色
Case 2: .Interior.Color = RGB(255, 204, 204) '日曜なら、淡いピンク色
Case 3: .Interior.Color = RGB(255, 153, 153) '祝日なら、濃いピンク色
Case 4: .Interior.Color = RGB(255, 255, 230) '平日なら、薄い黄色
End Select
End With
Next i
'************************************************************************************
'フィルター機能を使いたいので、書込み開始行(r1)の1つ上の行、つまり2行目をタイトル行にする。
sh1.Cells(r1 - 1, c1).FormulaR1C1 = " " '2行目に「半角スペース」を入力。
'入力した「半角スペース」をオートフィル機能でコピー
sh1.Cells(r1 - 1, c1).AutoFill Destination:= _
sh1.Range(sh1.Cells(r1 - 1, c1), sh1.Cells(r1 - 1, c2)), Type:=xlFillDefault
step1:
Set sh1 = Nothing: Set sh2 = Nothing
Call 画面更新等ON
Select Case b_case
Case 0: MsgBox "処理が終わったよ。"
Case 1: MsgBox "開始日付と最終日付を確認してください。終了します。"
Case 2: MsgBox "キャンセルされました。終了します。"
Case 3: MsgBox "配列（x）の上限を5000より、大きくしてください。終了します。"
End Select
End Sub
Private Sub 画面更新等OFF()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Private Sub 画面更新等ON()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub Macro2_お好み設定()
Dim sh1 As Worksheet, btn1 As Button, cbx1 As CheckBox, shp As Shape
Call 画面更新等OFF
Set sh1 = Sheets(sh_name1)
'今日の日付 -- TODAY関数
With sh1.Range("A1")
.Formula = "=TODAY()"
.HorizontalAlignment = xlCenter '（水平位置：真ん中）
.VerticalAlignment = xlCenter '（垂直位置：真ん中）
End With
'年間日数（4/1～翌年の3/31）（閏年は366、平年は365）
'「数式で日付の種類をカウント」←対象はA列の（3行目～5000行目）
With sh1.Range("K1")
.NumberFormatLocal = "#日" 'セルの表示形式
.Formula = "=COUNT(INDEX(1/(MATCH(A3:A5000,A3:A5000,)=ROW(A1:A5000)),))"
.HorizontalAlignment = xlCenter '（水平位置：真ん中）
.VerticalAlignment = xlCenter '（垂直位置：真ん中）
End With
'列の幅、行の高さを調整
sh1.Columns("A:A").ColumnWidth = 11# '（A1にTODAY関数が入るので）「A1=2016/12/12」
sh1.Columns("B:K").ColumnWidth = 7.38
sh1.Rows(1).RowHeight = 27
'印刷ページ設定（上下左右の余白）
With sh1.PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
End With
'ウィンドウ枠の固定を解除（念のため）してから､ウィンドウ枠の固定を設定
ActiveWindow.FreezePanes = False
sh1.Activate: sh1.Range("A3").Select: ActiveWindow.FreezePanes = True
'オートシェイプ全削除（念のため）
For Each shp In sh1.Shapes
shp.Delete
Next shp
'ボタン作成
With sh1
Set btn1 = .Buttons.Add(.Cells(1, 3).Left, _
.Cells(1, 3).Top, _
.Cells(1, 3).Width, _
.Cells(1, 3).Height)
End With
With btn1
.OnAction = "Macro5_印刷PreView" '★
.Text = "印刷"
.Name = "Button1"
End With
'チェックボックス作成
With sh1
Set cbx1 = .CheckBoxes.Add((.Cells(1, 2).Left + .Cells(1, 3).Left) * 0.5, _
.Cells(1, 2).Top, _
.Cells(1, 2).Width, _
.Cells(1, 2).Height)
End With
With cbx1
.OnAction = "フィルター機能" '★
.Text = ""
.Name = "CheckBox1"
.Display3DShading = True
.PrintObject = False
End With
Set sh1 = Nothing
Call 画面更新等ON
MsgBox "設定したよ"
End Sub
Sub Macro3_CheckBox_On()
Sheets("Sheet1").CheckBoxes("CheckBox1").Value = xlOn
Call フィルター機能
End Sub
Sub Macro4_CheckBox_Off()
Sheets("Sheet1").CheckBoxes("CheckBox1").Value = xlOff
Call フィルター機能
End Sub
Private Sub フィルター機能() '★ Dim sh1 As Worksheet, mx As Long, rng As String Dim d0 As Date, d1 As Date, d2 As Date, d3 As Date Dim d4 As Date, d5 As Date, d6 As Date
Set sh1 = Sheets(sh_name1)
Select Case sh1.CheckBoxes("CheckBox1").Value
Case xlOn
d0 = Format(Date, "m/d/yyyy") '★今日 ← 表示形式「m/d/yyyy」=「月/日/年」
d1 = Format(Date + 1, "m/d/yyyy") '★今日の1日後
d2 = Format(Date + 2, "m/d/yyyy") '★今日の2日後
d3 = Format(Date + 3, "m/d/yyyy") '★今日の3日後
d4 = Format(Date + 4, "m/d/yyyy") '★今日の4日後
d5 = Format(Date + 5, "m/d/yyyy") '★今日の5日後
d6 = Format(Date + 6, "m/d/yyyy") '★今日の6日後
'2行目（A列～K列）すべてに､何かしら値が入っていれば（半角スペースも値として取り扱う）､
If sh1.Range("A2:K2").SpecialCells(xlCellTypeConstants).Count = 11 Then
mx = sh1.Range("A" & Rows.Count).End(xlUp).Row
'フィルター機能
sh1.Range("A2").AutoFilter
sh1.Range("A2:K" & mx).AutoFilter Field:=1, Operator:=xlFilterValues, _
Criteria2:=Array(2, d0, 2, d1, 2, d2, 2, d3, 2, d4, 2, d5, 2, d6) '★
'フィルターで絞られたセル範囲（文字列）
rng = sh1.Range("A3:K" & mx).SpecialCells(xlCellTypeVisible).Address
ActiveSheet.PageSetup.PrintArea = rng '印刷範囲を設定
'フィルターで、検索日付とした日付をセルに書き込む
sh1.Range("D1").Value = Format(Date, "m/d (aaa)")
sh1.Range("E1").Value = Format(Date + 1, "m/d (aaa)")
sh1.Range("F1").Value = Format(Date + 2, "m/d (aaa)")
sh1.Range("G1").Value = Format(Date + 3, "m/d (aaa)")
sh1.Range("H1").Value = Format(Date + 4, "m/d (aaa)")
sh1.Range("I1").Value = Format(Date + 5, "m/d (aaa)")
sh1.Range("J1").Value = Format(Date + 6, "m/d (aaa)")
With sh1.Range("D1:J1")
.Font.Size = 9
.HorizontalAlignment = xlCenter '（水平位置：真ん中）
.VerticalAlignment = xlCenter '（垂直位置：真ん中）
End With
End If
Case xlOff
'フィルター機能を使いたいので、2行目(A～K列)をタイトル行にする。
sh1.Range("A2").FormulaR1C1 = " " '「半角スペース」
sh1.Range("A2").AutoFill Destination:=sh1.Range("A2:K2"), Type:=xlFillDefault
If sh1.FilterMode Then 'フィルター機能で、絞り込まれていたら
sh1.ShowAllData 'フィルター機能を解除
Selection.AutoFilter
ActiveSheet.PageSetup.PrintArea = "" '印刷範囲をクリア
sh1.Range("A1").Select
sh1.Range("D1:J1").ClearContents 'セル範囲を消去
End If
End Select
Set sh1 = Nothing End Sub
Sub Macro5_印刷PreView() '★
ActiveWindow.SelectedSheets.PrintPreview
End Sub
●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●
ファイルを置いておきます。（祝日シートは非表示にしてあります。）
（祝日シートの内容を修正したい場合は、手作業で非表示から表示にしてください。）
http://ww10.puny.jp/uploader/download/1459383733.zip
■１年分のスケジュールをマクロで作成（平日は６行、土日祝は１行）.xlsm （ダウンロードパスワード：abc）
（マリオ） 2016/03/31(木) 09:46
あと、印刷ボタンですが
二つボタンを作りたいです。一つは今日と明日のボタン
もう一つは、日付指定範囲ボタンでこれはあくまでも理想ですが
ボタンを押すと、日付入力指定ができるものです
例 日付を指定してください
4/1 ～ 4/5
キャンセル ＯＫ
ＯＫボタン押すと選んだ日付分のｎ列まで印刷する
実際の表は、ボタンを作ろうと思ってるので、
1行目にボタンを作成
2行目から4行目までに印刷設定したいです。
って初心者にも関わらずここまで注文するのがずうずうしぃて思うかもしれませんが
力を貸してください！！
よろしくお願い致します
（まいまい） 2016/03/31(木) 21:17
こんばんわ。
VBEの起動は、[Alt]+[F11]です。(Fはファンクションキーの事です) 後手動で起動の方法はここなどで勉強して下さい。 ボタン作成には開発タブが表示されていないといけないので、勉強して下さい。 (あるかも知れないけど、私は開発タブの挿入からしかやった事ないので、他の方法は知りません。) ボタンの作成はご自身で行ってもらわないといけません。 http://note.phyllo.net/?eid=1030710 http://brain.cc.kogakuin.ac.jp/~kanamaru/lecture/vba2003/2007_01-intro00.html 此方ではVBEのそれぞれの名称なども解説してくれています。 http://home.att.ne.jp/zeta/gen/excel/c04p43.htm
起動したら左上のプロジェクトエクスプローラーにシート名が出てきてると思いますが(無かったらExcel Objectsと言うのをダブルクリックして下さい) そこで(たぶんSheet1だと思うけど)コードを実行したいシート名を選択します。
右側のコードウィンドウが空白で何も書いてなかったら、一番上に Option Explicit を貼り付けて下さい。
その下に私のコードを丸ごと貼り付けて下さい。
そこまでが出来ないと次に進めないので、全く分からない所からは大変でしょうけど、これはご自身で頑張るしかありません。
そこまで出来たら、後はA3セルに日付を入力するだけです。
まぁ最低限上記の事が出来てからの話ですが、一つ目の質問の今日明日の印刷の範囲は、 ＞今日は良いとして明日が祝日などで休みの場合はどうなるのでしょう？ はどうするのですか？
後日付の範囲印刷に関して、範囲の指定はもちろんダイアログのようなフォームを作成して入力したり、
インプットボックスで(文字列になりますけど)順番に入力したりできますが、
初心者には難易度が高いので、下のようにセルに入力するのが一番分かり易くて、
コードも簡単になるので勉強する上で理解が早いと思うのですが、どうでしょう？
|[C] |[D]|[E] |[F]|
[1]|期間始| |期間至| |
それと2行目以降が印刷範囲と言う事は、3つ目の質問はラベルがあると言う事ですか？
今の時点では何もかも分からないでしょうから、コード作成依頼みたいな書き方になるのは仕方ないとしても、今回の目的の表を完成させる過程で、 質問回答などの会話を通してまいまいさんご自身が回答者の皆さんから提示されたコードを見て勉強すると言う姿勢は見せて下さい。 そうすれば私など足元にも及ばないような常連の人達からも、色々なアドバイスを受けれるようになると思います。
後マリオさんがサンプルブックを作ってくれているので、そちらも参考になると思います。 (まぁ初めはちんぷんかんぷんだと思いますが。。。)
（sy） 2016/03/31(木) 22:49
To まいまい さん
syさんが言われてますように、【開発タブ】の設定をしましょう！
フィルター機能で使用する検索日付を【InputBox】で指定できるように、ファイルを作り直しました！ スケジュール作成マクロ_02.xlsm（ダウンロードパスワード：abc） http://ww10.puny.jp/uploader/download/1459473110.zip （★作り直したコードは、落ち着いたら掲示板に書き込みます。）
■使い方
(1) スケジュール作成マクロ_02.xlsmを開く。「Sheet1」にデータがないことを確認してください。
また、「祝日」シートのA列(A2～)に祝日の日付が入力されていることを確認してください。
(2)「祝日」シートにある「1_日付書き込み」ボタン（K1:L1セルの領域）を押してください。
「上記の日付で、処理を行います。よろしいですか？」が表示されたら、ＯＫを押す。
「処理が終わったよ」が表示されたら、ＯＫを押す。
(3)「祝日」シートにある「2_お好み設定」 ボタン（N1:O1セルの領域）を押す。
「設定したよ」が表示されたら、ＯＫを押す。
(4)「Sheet1」ののC1セルにある「印刷」ボタンを押すと、印刷プレビュー画面になります。
印刷対象ページが２８ページあることを確認した後、印刷プレビュー画面を閉じてください。
(5)「Sheet1」ののB1セルにある【CheckBox】をONにすると、次のようなInputBoxが表示されます。
InputBox ２つの入力が終わったら、フィルター処理を行います。
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
先頭の検索日付を入力してください。
2016/4/1
ＯＫ キャンセル
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
何日後まで？
ex.)0 なら先頭の検索日付のみ（0または正の整数）
7
ＯＫ キャンセル
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
(6)「Sheet1」ののC1セルにある「印刷」ボタンを押して、印刷対象ページが１ページになっていることを
確認してください（フィルターで絞り込まれた日付範囲が表示されます）。
(7)「Sheet1」ののB1セルにある【CheckBox】をOFFにすると、フィルター機能が解除されます。
■2つ目のInputBoxのデフォルト値が【 7 】になってますが、【 1 】に変更したい場合は、次のようにしてください。
（変更前）
val_days = Application.InputBox(msg1, msg2, Default:=7)
（変更後）
val_days = Application.InputBox(msg1, msg2, Default:=1)
■次の値は、お好みで変更してください。
Const sh_name1 As String = "Sheet1" '★「日付書き込みシート」
Const sh_name2 As String = "祝日" '★「祝日設定シート」
Const d1 As Date = "2016/4/1" '★ 開始日付
Const d2 As Date = "2017/3/31" '★ 最終日付
Const j1 As Long = 6 '★ 平日なら6行
Const j2 As Long = 1 '★ 土日祝なら1行
（マリオ） 2016/04/01(金) 10:20
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ まいまいさんからは、何の返答もありませんが、せっかく作ったのでアップします。
作り直したファイル（スケジュール作成マクロ_02.xlsm）のコードです。
(1)「シート名：祝日」、「シート名：Sheet1」を作成してください。
(2)「シート名：祝日」に下記の■データΑ（*～*間のデータ）を入力してください。
(3)下記のコード(「Macro1_日付書き込み」～「ボタン作成」）をマクロブックのModule1にコピペしてください。
(4)順番に次のマクロを実行してください。
Macro1_日付書き込み → Macro2_お好み設定 → ボタン作成
(5)「シート名：祝日」、「シート名：Sheet1」にマクロを実行するチェックボックスとボタンが貼り付きます。
チェックボックスは、「シート名：Sheet1」のB1セルにあります。
以上
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
■データΑ：「シート名：祝日」
**************************************************************
|[A] |[B]
[1] |日付 |祝日名
[2] |2016/01/01|元日
[3] |2016/01/11|成人の日
[4] |2016/02/11|建国記念の日
[5] |2016/03/20|春分の日
[6] |2016/03/21|振替休日
[7] |2016/04/29|昭和の日
[8] |2016/05/03|憲法記念日
[9] |2016/05/04|みどりの日
[10]|2016/05/05|こどもの日
[11]|2016/07/18|海の日
[12]|2016/08/11|山の日
[13]|2016/09/19|敬老の日
[14]|2016/09/22|秋分の日
[15]|2016/10/10|体育の日
[16]|2016/11/03|文化の日
[17]|2016/11/23|勤労感謝の日
[18]|2016/12/23|天皇誕生日
[19]|2017/01/01|元日
[20]|2017/01/02|振替休日
[21]|2017/01/09|成人の日
[22]|2017/02/11|建国記念の日
[23]|2017/03/20|春分の日
[24]|2017/04/29|昭和の日
[25]|2017/05/03|憲法記念日
[26]|2017/05/04|みどりの日
[27]|2017/05/05|こどもの日
[28]|2017/07/17|海の日
[29]|2017/08/11|山の日
[30]|2017/09/18|敬老の日
[31]|2017/09/23|秋分の日
[32]|2017/10/09|体育の日
[33]|2017/11/03|文化の日
[34]|2017/11/23|勤労感謝の日
[35]|2017/12/23|天皇誕生日
**************************************************************
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
Option Explicit
Const sh_name1 As String = "Sheet1" '★「日付書き込みシート」
Const sh_name2 As String = "祝日" '★「祝日設定シート」
Const d1 As Date = "2016/4/1" '★ 開始日付
Const d2 As Date = "2017/3/31" '★ 最終日付
Const j1 As Long = 6 '★ 平日なら6行
Const j2 As Long = 1 '★ 土日祝なら1行
Const c1 As Long = 1 '書込み開始列（A列なら1）
Const c2 As Long = 11 '書込み最終列（K列なら11）
Const r1 As Long = 3 '書込み開始行（3行目からなら3）
Sub Macro1_日付書き込み()
Dim days As Long, mx As Long, k As Long, tmp As Date
Dim i As Long, j As Long, p As Long, r As Long
Dim msg1 As String, msg2 As String
Dim a_case As Long, b_case As Long
Dim sh1 As Worksheet, sh2 As Worksheet, sh As Worksheet
Dim ws_name As String
'既存シートに次の2つのシートがないとエラー →「インデックスが有効範囲にありません。」
Set sh1 = Sheets(sh_name1): Set sh2 = Sheets("祝日")
'sh2.Visible = True '非表示にしている祝日シートを一時的に表示する（後で非表示に戻す）
'************************************************************************************
'事前チェック その1（開始日付、最終日付）
If d2 < d1 Then '最終日付が、開始日付より前の日付になっていたら
b_case = 1: GoTo step1
End If
days = d2 - d1 + 1
'事前チェック その2（「日付書き込みシート」を初期化していいか確認）
msg1 = "上記の日付で、処理を行います。よろしいですか？" & vbCrLf & _
"（処理前に、シートを初期化します。）" & vbCrLf & vbCrLf & _
" 「日付書込み対象シート名：" & sh1.Name & "」"
msg2 = d1 & " --- " & d2
If MsgBox(msg1, vbOKCancel, msg2) = vbCancel Then
b_case = 2: GoTo step1
End If
'************************************************************************************
'画面更新等をOFFにして、「日付書き込みシート」を初期化（削除して新規シート作成）
Call 画面更新等OFF
For Each sh In ThisWorkbook.Worksheets
If sh.Name = sh_name1 Then
Application.DisplayAlerts = False
sh.Delete 'シートを削除
Application.DisplayAlerts = True
End If
Next
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sh_name1
Set sh1 = Sheets(sh_name1) '作り直したので、設定し直す
'************************************************************************************
'日付の配列（開始日付～最終日付）
ReDim d_array(1 To days) As Date
For i = 1 To days
d_array(i) = d1 + k: k = k + 1
Next i
'************************************************************************************
'祝日の配列（開始日付～最終日付のうち、祝日シートにあるもの）
ReDim Holiday_array(1 To 1) As Date
mx = sh2.Range("A" & Rows.Count).End(xlUp).Row: k = 0
For i = 2 To mx '★2行目から最終行まで（祝日の日付はA列にあるとしている）
If IsDate(sh2.Range("A" & i).Value) Then
tmp = sh2.Range("A" & i).Value
If tmp >= d1 And tmp <= d2 Then
k = k + 1: ReDim Preserve Holiday_array(1 To k): Holiday_array(k) = tmp
End If
End If
Next i
'************************************************************************************
ReDim x(1 To 5000, 1 To 1) As Date '★（適当に設定：5000）セルに書き込む日付の配列
ReDim t1(1 To days) As Long '各々の書式設定開始行を配列に格納
ReDim t2(1 To days) As Long '各々の書式設定最終行を配列に格納
ReDim t3(1 To days) As Long '各々の書式分類ナンバー（土：1、日：2、祝：3、平：4）
k = 0 '初期値
For i = 1 To days
If k > 5000 Then '★（適当に設定：5000）
b_case = 3: GoTo step1
End If
a_case = 4 '初期値（平日なら4）
If Weekday(d_array(i)) = 7 Then a_case = 1 '土曜なら1
If Weekday(d_array(i)) = 1 Then a_case = 2 '日曜なら2
For j = 1 To UBound(Holiday_array)
If Holiday_array(j) = d_array(i) Then a_case = 3 '祝日なら3（土日でも祝日なら3）
Next j
If a_case = 1 Or a_case = 2 Or a_case = 3 Then
For p = 1 To j2
x(k + p, 1) = d_array(i)
Next p
t1(i) = (r1 - 1) + k + 1: t2(i) = (r1 - 1) + k + j2: t3(i) = a_case
k = k + j2 'kを再設定
ElseIf a_case = 4 Then
For r = 1 To j1
x(k + r, 1) = d_array(i)
Next r
t1(i) = (r1 - 1) + k + 1: t2(i) = (r1 - 1) + k + j1: t3(i) = a_case
k = k + j1 'kを再設定
End If
Next i
'************************************************************************************
'セルに日付を書き込む（A列3行目～A列最終行）
With sh1.Range(sh1.Cells(r1, c1), sh1.Cells(k + 2, c1))
.NumberFormatLocal = "m/d (aaa)": .Value = x
End With
sh1.Columns(c1).AutoFit 'A列の幅を自動調整
'************************************************************************************
'書式設定（A列3行目～K列最終行）
With sh1.Range(sh1.Cells(r1, c1), sh1.Cells(k + 2, c2))
.Borders(xlEdgeTop).Weight = xlMedium '（上辺の線） 中太線
.Borders(xlInsideHorizontal).Weight = xlHairline '（内側の水平線）極細線
End With
For i = 1 To days
With sh1.Range(sh1.Cells(t1(i), c1), sh1.Cells(t2(i), c2))
.Borders(xlEdgeBottom).Weight = xlMedium '（下辺の線） 中太線
Select Case t3(i)
Case 1: .Interior.Color = RGB(197, 217, 241) '土曜なら、青色
Case 2: .Interior.Color = RGB(255, 204, 204) '日曜なら、淡いピンク色
Case 3: .Interior.Color = RGB(255, 153, 153) '祝日なら、濃いピンク色
Case 4: .Interior.Color = RGB(255, 255, 230) '平日なら、薄い黄色
End Select
End With
Next i
'************************************************************************************
step1:
'sh2.Visible = False
Set sh1 = Nothing: Set sh2 = Nothing
Call 画面更新等ON
Select Case b_case
Case 0: MsgBox "処理が終わったよ。"
Case 1: MsgBox "開始日付と最終日付を確認してください。終了します。"
Case 2: MsgBox "キャンセルされました。終了します。"
Case 3: MsgBox "配列（x）の上限を5000より、大きくしてください。終了します。"
End Select
End Sub
Sub Macro2_お好み設定()
Dim sh1 As Worksheet, btn1 As Button, btn2 As Button, btn3 As Button
Dim btn4 As Button, btn5 As Button, cbx1 As CheckBox, shp As Shape
Call 画面更新等OFF
Set sh1 = Sheets(sh_name1)
'今日の日付 -- TODAY関数
With sh1.Range("A1")
.Formula = "=TODAY()"
.HorizontalAlignment = xlCenter '（水平位置：真ん中）
.VerticalAlignment = xlCenter '（垂直位置：真ん中）
End With
'年間日数（4/1～翌年の3/31）（閏年は366、平年は365）
'「数式で日付の種類をカウント」←対象はA列の（3行目～5000行目）
With sh1.Range("K1")
.NumberFormatLocal = "#日" 'セルの表示形式
.Formula = "=COUNT(INDEX(1/(MATCH(A3:A5000,A3:A5000,)=ROW(A1:A5000)),))"
.HorizontalAlignment = xlCenter '（水平位置：真ん中）
.VerticalAlignment = xlCenter '（垂直位置：真ん中）
End With
'列の幅、行の高さを調整
sh1.Columns("A:A").ColumnWidth = 11# '（A1にTODAY関数が入るので）「A1=2016/12/12」
sh1.Columns("B:K").ColumnWidth = 7.38
sh1.Rows(1).RowHeight = 27
'印刷ページ設定（上下左右の余白）
With sh1.PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
End With
'ウィンドウ枠の固定を解除（念のため）してから､ウィンドウ枠の固定を設定
ActiveWindow.FreezePanes = False
sh1.Activate: sh1.Range("A3").Select: ActiveWindow.FreezePanes = True
'オートシェイプ全削除（念のため）
For Each shp In sh1.Shapes
shp.Delete
Next shp
'ボタン作成
With sh1
Set btn1 = .Buttons.Add(.Cells(1, 3).Left, _
.Cells(1, 3).Top, _
.Cells(1, 3).Width, _
.Cells(1, 3).Height)
End With
With btn1
.OnAction = "Macro5_印刷PreView"
.Text = "印刷"
.Name = "Button1"
End With
'**********************
With sh1
Set btn2 = .Buttons.Add(.Cells(1, 5).Left, _
.Cells(1, 5).Top, _
.Cells(1, 5).Width, _
.Cells(1, 5).Height)
End With
With btn2
.OnAction = "Macro6_本日"
.Text = "本日"
.Name = "Button2"
End With
'**********************
With sh1
Set btn3 = .Buttons.Add(.Cells(1, 6).Left, _
.Cells(1, 6).Top, _
.Cells(1, 6).Width, _
.Cells(1, 6).Height)
End With
With btn3
.OnAction = "Macro7_Top"
.Text = "Top"
.Name = "Button3"
End With
'**********************
With sh1
Set btn4 = .Buttons.Add(.Cells(1, 8).Left, _
.Cells(1, 8).Top, _
.Cells(1, 8).Width, _
.Cells(1, 8).Height)
End With
With btn4
.OnAction = "Macro8_Ribbon非表示"
.Text = "R非表示"
.Name = "Button4"
End With
'**********************
With sh1
Set btn5 = .Buttons.Add(.Cells(1, 9).Left, _
.Cells(1, 9).Top, _
.Cells(1, 9).Width, _
.Cells(1, 9).Height)
End With
With btn5
.OnAction = "Macro9_Ribbon表示"
.Text = "R表示"
.Name = "Button5"
End With
'チェックボックス作成
With sh1
Set cbx1 = .CheckBoxes.Add((.Cells(1, 2).Left + .Cells(1, 3).Left) * 0.5, _
.Cells(1, 2).Top, _
.Cells(1, 2).Width, _
.Cells(1, 2).Height)
End With
With cbx1
.OnAction = "フィルター機能"
.Text = ""
.Name = "CheckBox1"
.Display3DShading = True
.PrintObject = False
.Width = 15
End With
Set sh1 = Nothing
Call 画面更新等ON
MsgBox "設定したよ"
End Sub
Sub Macro3_CheckBox_On()
Sheets("Sheet1").CheckBoxes("CheckBox1").Value = xlOn
Call フィルター機能
End Sub
Sub Macro4_CheckBox_Off()
Sheets("Sheet1").CheckBoxes("CheckBox1").Value = xlOff
Call フィルター機能
End Sub
Private Sub フィルター機能()
Dim sh1 As Worksheet, mx As Long
Dim msg1 As String, msg2 As String
Dim val_d0 As Variant, val_days As Variant
Dim d0 As Date, dbl_days As Double, days As Integer
Dim i As Integer, k As Integer, flag As Boolean
Call 画面更新等OFF: Set sh1 = Sheets(sh_name1)
Select Case sh1.CheckBoxes("CheckBox1").Value
Case xlOn
'先頭の検索日付を指定（InputBox）
msg1 = "先頭の検索日付を入力してください。" & vbCrLf & _
"ex.) " & Format(Date, "yyyy/m/d") & " または、 " & _
Format(Date, "yyyy-m-d")
msg2 = "フィルター機能"
val_d0 = Application.InputBox(msg1, msg2, Default:=Format(Date, "yyyy/m/d"))
If VarType(val_d0) = vbBoolean Then
MsgBox "キャンセルされました。終了します。": flag = True: GoTo step1
ElseIf IsDate(val_d0) = False Then
MsgBox "入力値が日付ではありません。終了します。": flag = True: GoTo step1
End If
d0 = CDate(val_d0) 'Date型に型変換
'----------------------------------------------------------------------
'先頭の検索日付から、何日後までにするか指定(InputBox)
msg1 = "何日後まで？" & vbCrLf & _
"ex.) 0 なら先頭の検索日付のみ（0または正の整数）"
msg2 = "フィルター機能"
val_days = Application.InputBox(msg1, msg2, Default:=7) '★ex.) Default:=1
If VarType(val_days) = vbBoolean Then
MsgBox "キャンセルされました。終了します。": flag = True: GoTo step1
ElseIf IsNumeric(val_days) Then
dbl_days = CDbl(val_days) 'Double型に型変換
If Not (dbl_days = Int(dbl_days) And dbl_days >= 0) Then
MsgBox "ゼロまたは正の整数ではありません。終了します。"
flag = True: GoTo step1
End If
Else
MsgBox "数字ではありません。終了します。": flag = True: GoTo step1
End If
days = CInt(dbl_days) 'Integer型に型変換
'----------------------------------------------------------------------
'フィルター機能で使用する配列を作成（検索日付など）
ReDim myArray(1 To 2 * (days + 1))
For i = 0 To days
k = k + 1: myArray(k) = 2 '「年/月/日」の「日」が対象なので、「2」
k = k + 1: myArray(k) = d0 + i
Next i
'----------------------------------------------------------------------
'4行目をフィルター機能のタイトル行にする(A～K列)。3行目は、データを空に。
sh1.Rows("3:4").Insert '3行目と4行目を挿入
sh1.Range("A4").FormulaR1C1 = "■"
sh1.Range("A4").AutoFill Destination:=sh1.Range("A4:K4"), _
Type:=xlFillDefault
sh1.Rows("3:4").RowHeight = 0 '行の高さを0にして見えないようにする。
'----------------------------------------------------------------------
'フィルター機能
mx = sh1.Range("A" & Rows.Count).End(xlUp).Row
sh1.Range("A4").AutoFilter '4行目をフィルター機能のタイトル行にする。
sh1.Range("A4:K" & mx).AutoFilter Field:=1, Operator:=xlFilterValues, _
Criteria2:=myArray
Case xlOff
If sh1.FilterMode Then 'フィルター機能で、絞り込まれていたら
sh1.ShowAllData: Selection.AutoFilter 'フィルター機能を解除
End If
If WorksheetFunction.CountIf(sh1.Range("A4:K4"), "■") = 11 Then
sh1.Rows("3:4").Delete '3行目と4行目を削除
End If
End Select
'選択セルとスクロール位置をA3セルに変更する、その後、選択セルをA1セルにする。
Application.Goto Reference:=sh1.Range("A3"), Scroll:=True: sh1.Range("A1").Select
step1:
If flag = True Then sh1.CheckBoxes("CheckBox1").Value = xlOff
Set sh1 = Nothing: Call 画面更新等ON
End Sub
Sub Macro5_印刷PreView()
ActiveWindow.SelectedSheets.PrintPreview
End Sub
Sub Macro6_本日()
Dim sh1 As Worksheet, Date1 As Date, mx As Long
Dim i As Long, flag As Boolean
Set sh1 = Sheets(sh_name1)
Date1 = Date '今日の年月日
mx = sh1.Range("A" & Rows.Count).End(xlUp).Row:
For i = 3 To mx
If Date1 = Range("A" & i).Value Then
flag = True: Exit For
End If
Next i
Select Case flag
Case True: Application.Goto Reference:=sh1.Range("A" & i), Scroll:=True
Case Else: MsgBox "今日の日付を探せません"
End Select
Set sh1 = Nothing
End Sub
Sub Macro7_Top()
Dim sh1 As Worksheet
Set sh1 = Sheets(sh_name1)
Application.Goto Reference:=sh1.Range("A3"), Scroll:=True
sh1.Range("A1").Select
Set sh1 = Nothing
End Sub
Sub Macro8_Ribbon非表示()
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
End Sub
Sub Macro9_Ribbon表示()
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
End Sub
Private Sub 画面更新等OFF()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Private Sub 画面更新等ON()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub VBA起動()
SendKeys "%{F11}", True '（Alt+F11）Visual basic Editorを開く
End Sub
Sub 上書き保存()
Application.DisplayAlerts = False
ActiveWorkbook.Save
MsgBox "上書き保存しました。"
Application.DisplayAlerts = True
End Sub
Sub ボタン作成()
Dim sh2 As Worksheet, btn6 As Button, btn7 As Button, btn8 As Button, btn9 As Button
Set sh2 = Sheets(sh_name2)
'ボタン作成
With sh2
Set btn6 = .Buttons.Add(.Cells(1, 5).Left, _
.Cells(1, 5).Top, _
.Range(sh2.Cells(1, 5), sh2.Cells(1, 6)).Width, _
.Cells(1, 5).Height)
End With
With btn6
.OnAction = "VBA起動"
.Text = "VBA起動 (Alt+F11)"
.Name = "Button6"
End With
'***************************************
With sh2
Set btn7 = .Buttons.Add(.Cells(1, 8).Left, _
.Cells(1, 8).Top, _
.Range(sh2.Cells(1, 8), sh2.Cells(1, 9)).Width, _
.Cells(1, 8).Height)
End With
With btn7
.OnAction = "上書き保存"
.Text = "上書き保存"
.Name = "Button7"
End With
'***************************************
With sh2
Set btn8 = .Buttons.Add(.Cells(1, 11).Left, _
.Cells(1, 11).Top, _
.Range(sh2.Cells(1, 11), sh2.Cells(1, 12)).Width, _
.Cells(1, 11).Height)
End With
With btn8
.OnAction = "Macro1_日付書き込み"
.Text = "1_日付書き込み"
.Name = "Button8"
End With
'***************************************
With sh2
Set btn9 = .Buttons.Add(.Cells(1, 14).Left, _
.Cells(1, 14).Top, _
.Range(sh2.Cells(1, 14), sh2.Cells(1, 15)).Width, _
.Cells(1, 14).Height)
End With
With btn9
.OnAction = "Macro2_お好み設定"
.Text = "2_お好み設定"
.Name = "Button9"
End With
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ フィルター機能で使用する検索日付を【InputBox】で指定できるように、 ファイルを作り直しました！上記は、そのコードです。 下記のそのファイルを置いておきます。
スケジュール作成マクロ_02.xlsm（ダウンロードパスワード：abc） http://ww10.puny.jp/uploader/download/1459473110.zip
（マリオ） 2016/04/02(土) 22:38
こんばんわ。 休みなので見るのは明日でしょうか？
まだ印刷に関する要件などで不明な点がありますが、 私ならこうするかなと言うのを書いたので載せておきます。 シート名は便宜的に[日付リスト]シートと[祝日]シートと言う呼び方をしています。
1、今日明日分の印刷の時、休日分を加算して印刷などに関しては、 日付指定印刷の方で賄えるので、単純に2日分のみ印刷。
2、期間指定印刷の指定方法は、誰が見ても分かり易いのと、
コードが簡単に出来るので、下記のようにD1セルとF1セルに日付を入力。
|[C] |[D]|[E] |[F]|
[1]|期間始| |期間至| |
3、1週間分までは印刷方向を横に、それ以上の期間を印刷する時は縦で印刷。
4、長い期間の印刷時、行方向は数ページに分けて2行目を見出し行に設定、 列方向は1ページ分に収まるように印刷設定。
5、日付リストの作成は、頻度的に年に1回くらいの少ないものなので、 A3セルのチェンジ判定では無くて、リスト作成ボタンをクリックで作成。
6、各ボタンは、ActiveXコントロールのCommandButtonを使用。
CommandButton1 今日明日印刷
CommandButton2 期間指定印刷
CommandButton3 リスト作成
フォームボタンを使用したい場合は少し加工が必要です。
上記の仕様で書きました。 また日付指定はどちらか片方だけ入力の場合は1日分、 両方入力すれば、その間の期間分印刷されます。 期間始と期間至にしてますが、自動で判別するので、 どちらが先の日付になっても構いません。
前回記載した方法でVBEを開いて、日付リストシートのコードウィンドウに下記コード (前回までに書いた分は今回の中に含まれてますので破棄して下さい) を全て貼り付けて下さい。
後はボタンを3つ作成するだけですが、 [開発タブ]の[挿入]から2種類ボタンがありますが、 ActiveXの方のCommandButtonを選んで3つ作成して下さい。 ボタンを選択して、右クリック→プロパティでプロパティウィンドウを表示して、 Captionがボタンの表示名になるので、[今日明日][期間指定][リスト作成] などと分かり易い名前にして下さい。 大きさや位置などは、図形などと同じような操作で変えれます。 (プロパティウィンドウからも数値で変更可能)
分からない事があれば、都度質問して下さい。
下の Option Explicit はご自身で設定されたのなら必要ないので、 その下の Private Sub CommandButton1_Click() から貼り付けて下さい。
Option Explicit
Private Sub CommandButton1_Click()
'今日と明日の印刷
Call pOut(Date, Date + 1)
End Sub
Private Sub CommandButton2_Click()
'指定した期間の印刷
Call pOut(Range("D1").Value, Range("F1").Value)
End Sub
Private Sub CommandButton3_Click()
'リスト作成
Call ListCreate(Range("A3").Value)
End Sub
Sub pOut(ByVal day1 As Date, ByVal day2 As Date)
Dim fday As Date
Dim fRow As Long
Dim rowCnt As Integer
Dim i As Integer
Dim j As Long
'期間指定の場合空欄や日付の逆転をチェック
If day1 = 0 And day2 = 0 Then Exit Sub
fday = day1
j = Abs(day1 - day2)
If day1 > day2 And day2 > 0 Or day1 = 0 Then fday = day2
If day1 = 0 Or day2 = 0 Then j = 0
'印刷設定
With ActiveSheet.PageSetup
.PrintArea = "$A:$K" '印刷範囲
.PrintTitleRows = "$2:$2" '行ラベルの指定
.FitToPagesTall = 100
.FitToPagesWide = 1 '横を1ページに収める
.Orientation = xlPortrait '用紙方向縦に設定
End With
'期間の日付範囲を取得
rowCnt = WorksheetFunction.CountIf(Range("A:A"), fday)
If rowCnt > 0 Then
fRow = WorksheetFunction.Match(CLng(fday), Range("A:A"), 0)
Else
Exit Sub
End If
For i = 1 To j
rowCnt = rowCnt + WorksheetFunction.CountIf(Range("A:A"), fday + i)
Next i
'印刷期間が一週間以内は用紙方向横に設定
If j <= 7 Then ActiveSheet.PageSetup.Orientation = xlLandscape
'印刷範囲の下側に直線の罫線を引く
Range("A1:K1").Rows(fRow + rowCnt - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
'印刷プレビュー
Range("A" & fRow).Resize(rowCnt).EntireRow.PrintOut Copies:=1, Preview:=True
'印刷プレビューを直接印刷にする場合は、 Preview:=True を消して下さい
End Sub
Sub ListCreate(ByVal fDate As Variant)
Dim i As Long
Dim cnt As Integer
Dim shPH As Worksheet
'A3セルに有効な日付が無い場合はキャンセル
If fDate = "" Then Exit Sub
If Not IsDate(fDate) Then Exit Sub
'画面描画やイベント重複の停止
Application.ScreenUpdating = False
'変数のセット
Set shPH = Sheets("祝日")
cnt = 1
'日付と罫線の作成表示
Range("A4:A3000").EntireRow.Delete Shift:=xlUp '以前のデータを初期化
Range("A3:K3").Borders(xlEdgeTop).LineStyle = xlContinuous
'4行目以降の日付と罫線作成
For i = 4 To 2196
'条件に合わせて処理を変更
Select Case True
'一つ上の行の曜日で処理、5は土日祝1行、6は日祝1行、該当すれば次の日を作成
Case Weekday(Cells(i - 1, "A").Value, vbMonday) > 6 '←この数字を6にすれば土曜も6行になります。
Cells(i, "A").Value = Cells(i - 1, "A").Value + 1
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
'一つ上の行が祝日なら次の日を作成
Case WorksheetFunction.CountIf(shPH.Range("A:A"), Cells(i - 1, "A").Value) > 0
Cells(i, "A").Value = Cells(i - 1, "A").Value + 1
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
'一つ上の行が6行目なら次の日を作成
Case cnt = 6
Cells(i, "A").Value = Cells(i - 1, "A").Value + 1
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
cnt = 1
'それ以外は6行目まで同じ日を作成
Case Else
Cells(i, "A").Value = Cells(i - 1, "A").Value
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlDot
cnt = cnt + 1
End Select
'現在の行が一年後の4月1日なら削除して終端の罫線設定
If Cells(i, "A").Value = DateSerial(Year(Cells(3, "A").Value) + 1, 4, 1) Then
Cells(i, "A").EntireRow.Delete Shift:=xlUp
Range("A1:K1").Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous
Exit For
End If
Next i
'A列を日付(曜日)書式に変更
Range("A:A").NumberFormatLocal = "m/d (aaa)"
'変数の解除
Set shPH = Nothing
'画面再描画、イベン実行待機状態に戻す
Application.ScreenUpdating = True
End Sub
（sy） 2016/04/03(日) 22:33
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.