'========================================================================================= ' 496 進捗表作成 '----------------------------------------------------------------------------------------- '【ヒント】 ' このマクロは、おためし機能の動作用のコードです。 ' Module2シートのマクロが、タイトル機能のコードです。 '========================================================================================= ' ◆標準モジュールのコード◆ '----------------------------------------------------------------------------------------- '----------------------------------------------------------------------------------------- Sub おためしマクロ() おためしメッセージを表示する End Sub '----------------------------------------------------------------------------------------- Private Sub おためしメッセージを表示する() Worksheets("進捗").Select Range("A1").Select 'カーソルを定位置へ移動する タイトル = "500連発 第2弾 サンプルマクロ" スタイル = 64 'vbInformation メッセージ = "このデータで作図して良ければ、" & Chr(13) & Chr(13) & _ "OKボタンを押してから作図ボタンを押してください。" & Chr(13) & Chr(13) & _ "データを変えたければ、OKボタンを押した後で変更し" & Chr(13) & Chr(13) & _ "その後で作図ボタンを押してください" 応答 = MsgBox(メッセージ, スタイル, タイトル) End Sub '----------------------------------------------------------------------------------------- Sub Auto_Close() Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close '現在開いているブックを閉じる End Sub '----------------------------------------------------------------------------------------- '========================================================================================= ' ★ 進捗表作成 V1.1 ★ Copyright(c)1999-2000 Yoshioh Nagai '========================================================================================= Option Explicit Dim 曜(7) As String Dim 下 As Variant Dim 右 As Variant Dim 日数 As Integer Dim メッセージ As String Dim I As Integer Dim j As Integer Dim シリアル '----------------------------------------------------------------------------------------- Sub 進捗表を作成する() 進捗シートの有効範囲を調べる If 下 < 9 Then '十分なデータがあるかチェックする MsgBox "データが少ないので作業を続けれません", vbCritical, "進捗表作成" Exit Sub End If 加工シートを初期化して数式シートの内容を写し進捗シートのデータ数分の行を用意する 進捗シートのデータを項目シートに写す 数式シートから加工シートへ所要日数の数式を写す 加工シート内で数式シートから写した色々な数式を展開する 加工シート内で基点年月日から現在年月日までの日付別エリアを展開する 加工シートに曜日を記入し月を見やすくして矢印セルに着色する 加工シートの不要な網掛けを消してから進捗シートに写して列幅を調整する End Sub '----------------------------------------------------------------------------------------- Private Sub 進捗シートの有効範囲を調べる() Sheets("進捗").Select ActiveSheet.Unprotect 'シート保護解除 下 = Range("A6").End(xlDown).Row '項目の列の下端選択 End Sub '----------------------------------------------------------------------------------------- Private Sub 加工シートを初期化して数式シートの内容を写し進捗シートのデータ数分の行を用意する() Sheets("加工").Select Cells.Clear '全てクリア ' Sheets("数式").Select ActiveSheet.Unprotect 'シート保護解除 Range("A1:W7").Copy 'テンプレートをコピー Sheets("加工").Select Range("A1").PasteSpecial Paste:=xlAll '全て貼り付け ' Range("A7:W7").Copy 'データの1行目をコピー Range(Cells(8, 1), Cells(下, 23)).Select 'データ範囲を選択 Selection.PasteSpecial Paste:=xlFormats '書式だけ貼り付け End Sub '----------------------------------------------------------------------------------------- Private Sub 進捗シートのデータを項目シートに写す() Sheets("進捗").Select Range(Cells(1, 1), Cells(下, 17)).Copy 'データ範囲をコピー Sheets("加工").Select Range("A1").PasteSpecial Paste:=xlValues '値を貼り付け End Sub '----------------------------------------------------------------------------------------- Private Sub 数式シートから加工シートへ所要日数の数式を写す() Sheets("数式").Select Range("N7").Copy '所要日数の数式をコピー Sheets("加工").Select Range(Cells(7, 14), Cells(下, 14)).PasteSpecial Paste:=xlFormulas '数式を貼り付け Sheets("数式").Select ActiveSheet.Protect DrawingObjects:=True, _ Contents:=True, Scenarios:=True 'シート保護 End Sub '----------------------------------------------------------------------------------------- Private Sub 加工シート内で数式シートから写した色々な数式を展開する() Sheets("加工").Select Range("R7:W7").Copy '年4桁補正とシリアル値と矢印の数式をコピー Range(Cells(8, 18), Cells(下, 23)).PasteSpecial Paste:=xlFormulas '数式を貼り付け End Sub '----------------------------------------------------------------------------------------- Private Sub 加工シート内で基点年月日から現在年月日までの日付別エリアを展開する() Sheets("加工").Select Range("W5").Value = Range("T2").Value '基点年月日シリアル 日数 = Cells(3, 21) - Cells(2, 20) '現在年月日シリアル - 基点年月日シリアル For I = 1 To 日数 Range(Cells(2, 23), Cells(下, 23)).Copy '初日の列をコピー Range(Cells(2, 23 + I), Cells(下, 23 + I)).PasteSpecial Paste:=xlAll 'すべて貼り付け Range(Cells(5, 23 + I), Cells(5, 23 + I)).Value = Range(Cells(5, 22 + I), Cells(5, 22 + I)).Value + 1 Next With Range(Cells(2, 22 + I), Cells(下, 22 + I)).Borders(xlRight) .Weight = xlThin End With '最右側線を引く End Sub '----------------------------------------------------------------------------------------- Private Sub 加工シートに曜日を記入し月を見やすくして矢印セルに着色する() 曜(1) = "日": 曜(2) = "月": 曜(3) = "火": 曜(4) = "水": 曜(5) = "木": 曜(6) = "金": 曜(7) = "土" Sheets("加工").Select For I = 1 To 日数 + 1 シリアル = Range(Cells(5, 22 + I), Cells(5, 22 + I)).Value '年月日シリアル値 Range(Cells(6, 22 + I), Cells(6, 22 + I)).Value = 曜(Weekday(シリアル)) '曜日を記入する If I <> 1 And Range(Cells(3, 22 + I), Cells(3, 22 + I)).Value <> 1 Then '1日でないなら Range(Cells(2, 22 + I), Cells(2, 22 + I)).ClearContents '月の数式と値をクリアする Range(Cells(2, 22 + I), Cells(2, 22 + I)).Borders(xlLeft).LineStyle = xlNone '左側線を消す End If For j = 7 To 下 '7行目から下端行まで If Range(Cells(j, 22 + I), Cells(j, 22 + I)).Value <> "" Then 'Nullでないなら（矢印があれば） Range(Cells(j, 22 + I), Cells(j, 22 + I)).Interior.ColorIndex = 6 '着色する End If Next Next End Sub '----------------------------------------------------------------------------------------- Private Sub 加工シートの不要な網掛けを消してから進捗シートに写して列幅を調整する() Sheets("加工").Select Range(Cells(7, 14), Cells(下, 14)).Interior.ColorIndex = xlNone '所要日数の網掛けを消す Range(Cells(2, 18), Cells(下, 21)).Interior.ColorIndex = xlNone '非表示セルの網掛けを消す Range("A2").SpecialCells(xlLastCell).Select '最後のセルを選択する 右 = ActiveCell.Column 'アクティブセルの列番号を取得する Range(Cells(2, 1), Cells(下, 右)).Copy '完成図をコピーする Sheets("進捗").Select Range("A2").PasteSpecial Paste:=xlValues '値を貼り付け Range("A2").PasteSpecial Paste:=xlFormats '書式を貼り付け Range(Cells(1, 23), Cells(1, 右)).ColumnWidth = 2.5 '列幅を調整する（W〜右端列） Range("A1").Select 'カーソルを移動する ActiveSheet.Protect DrawingObjects:=True, _ Contents:=True, Scenarios:=True 'シート保護 End Sub '========================================================================================= ' V1.1 2000.5.5　　　　　　　　　　　　　　　　　　　　　　　ExcelVBAマクロ 500連発 第2弾 '=========================================================================================