ほげーむわーく

宿題をゲームのように楽しむブログ

エクセルで最強の進捗管理表を作る【③予定表作成編】

f:id:takehito33711:20190110232029j:plain


今回は予定表のフォーマットと予定バー入力のイベントを作成していきます。
前回の記事がこちら。

takehito33711.hatenablog.com


そして今回の完成のイメージはこんな感じです。
範囲を選択して右クリックすると予定バーが入力されるような形です。

f:id:takehito33711:20191010223139g:plain

予定表フォーマットを作成しよう

まずは予定表のフォーマットを作成します。
エクセルシートの名前を「予定表」に変更します。

f:id:takehito33711:20191010230111p:plain


そしたら下記のコードを打ち込んで実行してみてください。
12~18行目の初期設定の部分には好みに合わせて適宜変更してください。

Public Sub 予定表フォーマット作成()
    
Dim i As Long                                  'カウンタ
Dim StartDay As Date                        '開始日
Dim EndDay As Date                         '終了日
Dim LastRow As Long                        'カレンダーの行数
Dim StartColumn As Long                 '日付開始列
Dim WS As Worksheet                      'ワークシート「予定表」
Dim iRange As Range
Dim Color As Long                            'テーマ色
    
 '*******初期設定*******************************************
Set WS = Worksheets("予定表")
StartDay = DateAdd("d", -10, Date)
EndDay = DateAdd("d", 10, Date)
Color = RGB(201, 252, 113)
StartColumn = 6
LastRow = 10
 '**********************************************************
'表示のクリア    
WS.Cells.SpecialCells(xlCellTypeVisible).Clear
    
 '内容の表示************************************************
WS.Cells(2, 2) = "テーマ名"
WS.Cells(2, 3) = "内容"
WS.Cells(2, 4) = "担当者"
WS.Cells(2, 5) = "備考"
   
'セルの結合
For i = 2 To 5
Range(Cells(2, i), Cells(5, i)).Merge
Next i
 '**********************************************************
    
'日付表示*********************************************************************************************
For i = 0 To EndDay - StartDay
WS.Cells(1, StartColumn + i) = CDbl(DateAdd("d", i, StartDay))
WS.Cells(2, StartColumn + i) = Year(WS.Cells(1, StartColumn + i))
WS.Cells(3, StartColumn + i) = Month(DateAdd("d", i, StartDay))
WS.Cells(4, StartColumn + i) = Day(DateAdd("d", i, StartDay))
WS.Cells(5, StartColumn + i) = WeekdayName(Weekday(WS.Cells(1, StartColumn + i)), True, vbSunday)
Next i
    
 '****************************************************************************************************
    
 '罫線の設定***********************************************************************************************
    
 '罫線のクリア
WS.Cells.SpecialCells(xlCellTypeVisible).Borders.LineStyle = xlNone
    
'罫線の描画
With Range(WS.Cells(2, 2), WS.Cells(LastRow, StartColumn + EndDay - StartDay))
        .Borders.LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlMedium
End With
    
'罫線の描画(太字)
With Range(Cells(2, 2), Cells(5, StartColumn + EndDay - StartDay))
        .Borders.Weight = xlMedium
End With
    
'罫線の描画(二重線)
With Range(Cells(2, 5), Cells(LastRow, 5))
        .Borders(xlEdgeRight).Weight = xlThick
End With
    
'土日の色付け
For Each iRange In Range(WS.Cells(5, StartColumn), WS.Cells(5, StartColumn + EndDay - StartDay))
    If iRange = "土" Or iRange = "日" Then
    Range(WS.Cells(5, iRange.Column), WS.Cells(LastRow, iRange.Column)).Interior.Color = 16773119
    End If
Next iRange
    
'外枠罫線の設定
Range(WS.Cells(2, 2), WS.Cells(LastRow, StartColumn + EndDay - StartDay)).BorderAround Weight:=xlThick
    
'***********************************************************************************************************
    
'色の設定****************************************************************************************************
Range(WS.Cells(2, 2), WS.Cells(5, StartColumn + EndDay - StartDay)).Interior.Color = Color
Range(WS.Cells(1, 2), WS.Cells(1, StartColumn + EndDay - StartDay)).Font.Color = vbWhite
'***********************************************************************************************************
    
'調整******************************************
For i = 1 To EndDay - StartDay
        
        '月の変わり目の設定
        If WS.Cells(4, StartColumn + i) <> 1 Then
        WS.Cells(2, StartColumn + i) = ""
        WS.Cells(3, StartColumn + i) = ""
        
        Else
        
        With Range(WS.Cells(2, StartColumn + i), WS.Cells(LastRow, StartColumn + i))
            .Borders(xlEdgeLeft).LineStyle = xlDouble
        End With
        
        End If
        
'本日の日付の強調
        If WS.Cells(1, StartColumn + i) = CDbl(Date) Then
        Range(WS.Cells(2, StartColumn + i), WS.Cells(LastRow, StartColumn + i)).Interior.Color = vbYellow
        End If
    
Next i
'**********************************************
    
End Sub

フォーマットが作成されたでしょうか。


イベントを作成しよう

次にイベントの作成をします。
範囲を選択して右クリックでバーが表示されるようにします。

まずVBAの画面を開き、下図のように
①「予定表シート」を選択し、
② Worksheetを選択し、
③ BeforeRightClickを選択します。

BeforeRightClick内に記述したコードが、右クリックを押されるたびに実行されることになります。

f:id:takehito33711:20191010231144p:plain


準備できたら下のコードを記述します。
バーは立体的に見えるような工夫をしてみました。

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)        

Dim LeftColumn As Long                                  '選択範囲の左端
Dim RightColumn As Long                                 '選択範囲の右端
Dim ActiveRow As Long                                   '選択範囲の行位置
Dim sHeight As Long: sHeight = Range("A6").Height       '図形の高さ
Dim shp As Shape                                            '図形
Dim shpName As String                                   '図形の名前
Dim ShapeRow As Long                                   '図形の行位置
Dim shpColor                                                   '図形の色
Dim WS As Worksheet
    
'初期設定****************************************************
Set WS = Worksheets("予定表")
LeftColumn = Selection(1).Column
RightColumn = Selection(Selection.Count).Column
ActiveRow = ActiveCell.Row
shpColor = RGB(91, 161, 99)
'************************************************************
 
'項目が入力されている範囲には適用されないよう処理   
 If ActiveCell.Row >= 6 And ActiveCell.Column >= 6 Then

    '図形の大きさ設定
    Set shp = ActiveSheet.Shapes.AddShape(Type:=msoShapeRoundedRectangle, _
                                Left:=Cells(ActiveRow, LeftColumn).Left, _
                                Top:=Cells(ActiveRow, LeftColumn).Top, _
                                Width:=Selection.Width, _
                                Height:=sHeight * 1)
    shp.Select
    
    Selection.ShapeRange.Line.Visible = msoFalse
    
    '図形の属性設定
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = shpColor
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = -0.25
        .Transparency = 0
        .Solid
    End With
    
    With Selection.ShapeRange.ThreeD
        .BevelTopType = msoBevelCoolSlant
        .BevelTopInset = 13
        .BevelTopDepth = 6
    End With
    With Selection.ShapeRange.ThreeD
        .BevelBottomType = msoBevelCircle
        .BevelBottomInset = 6
        .BevelBottomDepth = 6
    End With
    
    '図形の文字設定
    Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 6.5
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
        msoAlignCenter
    With Selection.ShapeRange.TextFrame2.TextRange.Font
        .NameComplexScript = "Times New Roman"
        .NameFarEast = "Times New Roman"
        .Name = "Times New Roman"
    End With
    
    '★★★★★

    Set shp = Nothing
    
 End If
        
End Sub


記述ができたらワークシートに戻って範囲を選択して右クリックしてみてください。
バーが出現したら成功です。

そしてこのコードにはまだ続きがあります。
それが66行目の★★★★★です。
ここには次回以降にある仕掛けを施す予定なので楽しみにしていてください。

お疲れ様でした~。