Go to Qiita Advent Calendar 2024 Top
LoginSignup
5
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

Visual BasicAdvent Calendar 2024

Day 17
@rie1234k

Excel VBA 予定一覧から予定管理用カレンダーを作成する

Last updated at Posted at 2024-12-17

はじめに

以下のエクセルで作成した予定一覧をカレンダー形式にして予定を管理したい。
カレンダー形式にチェック欄を設け、完了したらチェックを入れる仕組みを検討する。

予定一覧.jpg

作成したいマクロのイメージ

カレンダーシートを作成し、予定一覧をカレンダーに表示させる。
カレンダーにチェック欄を設け、カレンダーにチェックを入れると、予定一覧にもチェックが入るようにする。

作成したマクロの概要

予定の入力・変更は予定一覧で行い、以下のようなカレンダーで閲覧する形式とした。
チェック欄については、カレンダーからでもチェックを入れられるようにしてある。
予定欄等にはHYPERLINK関数を入力し、予定一覧へ移動できる。

カレンダーサンプル.jpg

チェック欄について、検討した結果、ハイパーリンクをクリックすると発生する「Workbook.SheetFollowHyperlink」イベントを使用してチェックを入れることにした。
まず、カレンダーのチェック欄は、予定一覧のチェック欄のセル参照とする。
そのカレンダーのチェック欄に、該当する予定一覧のチェック欄へ移動するハイパーリンクを設定し、ハイパーリンクをクリックすると、予定一覧のチェック欄に移動する。
そこで、SheetFollowHyperlinkイベントが発生するので、移動した予定一覧のチェック欄にチェックを入れて、カレンダーシートに戻る仕組みとした。
また、HYPERLINK関数では、「Workbook_SheetFollowHyperlink」イベントが起きないため、予定等にはHYPERLINK関数を入力し、一覧の該当欄へ移動できるようにした。

祝日リストの作成は、以下の内閣府「国民の祝日」についてのページにある国民の祝日のCSVファイルを使用した。

役割ごとに各モジュールで6つのプロシージャを作成した。

  • 標準モジュール１
    ①「Write_Calendar」Subプロシージャ：カレンダーシートに予定を書き込み
    ②「Create_CalendarSheet」Functionプロシージャ：カレンダーシートを作成して返す
    　
  • 標準モジュール２
    ③「GetDownloadFilePath」Functionプロシージャ：
    　祝日データ用ファイルをダウンロードし、保存したファイルのパスを返す
    ④「Update_NationalHolidayList」プロシージャ：祝日リストを作成する

※③、④はカレンダーの祝日の色を変えるためオプションで追加、なくてもよい

  • ThisWorkbookモジュール
    ⑤「Workbook_SheetFollowHyperlink」イベントプロシージャ：
    　ハイパーリンクをクリックした時に移動先のセルへチェックを入れる
    　
  • シートモジュール（予定一覧シート）
    ⑥「Worksheet_BeforeDoubleClick」イベントプロシージャ：
    　予定一覧の日付をダブルクリックすると、カレンダーの該当日の予定欄に移動する

動作手順

標準モジュール１

①「Write_Calendar」プロシージャ

  1. 予定一覧を昇順に並び替える
  2. 各日付の予定件数をコレクション化
  3. 予定一覧のチェック欄にチェックを入れるためのハイパーリンクを設定
  4. 「Create_CalendarSheet」を呼び出して、カレンダーを作成し、シートを取得
  5. カレンダーの各週の予定表示行数を予定件数に合わせて調整
  6. 日付ごとに予定をコレクション化
  7. コレクション化した予定をカレンダーシートに書き込み
    （Findメソッドで日付検索、予定はHYPERLINK関数、チェック欄はハイパーリンク設定）
  8. ブックのハイパーリンクの書式を変更し、カレンダーシートを保護
    (セルのスタイルにFollowed Hyperlink [表示済みのハイパーリンク] がない場合もあるため、Like演算子で「*Hyperlink」を含むスタイル名に対して処理する形にした)

　
②「Create_CalendarSheet」Functionプロシージャ

  1. 「カレンダー」シートがある場合、シートを削除
  2. 「カレンダー」シートを作成し、目盛線、倍率などを設定
  3. B1セルにカレンダーの開始月の1日の日付を入力し、文字色を白にする　
  4. B2～F2セルを結合し、カレンダーのタイトルを入力
  5. B3～AC3セルに、カレンダーの1マスを4列として、1～7の数字を振る
  6. B4～E7セルに、カレンダーの1マスを作成する
  7. 条件付き書式（チェックを入れた予定、当日・土日の日付の色を変える）を設定
  8. 2週目用のカレンダーマスを作成
  9. 必要な週を計算し、オートフィルでカレンダーを作成
    （Endプロパティで行数を確認するため、最後の月の翌月の1週間分まで作成）
  10. 作成したカレンダーシートを返す

補足：カレンダーの作り方について

カレンダーの作り方については様々な方法があると思うが、1～7の番号を振り、その番号とWEEKDAY関数、その月の1日の日付を使って、1日の曜日の位置を計算する方法とした。

カレンダー例.png

標準モジュール２

③「GetDownloadFilePath」Functionプロシージャ
※ファイルダウンロード用のAPI宣言をモジュールの一番先頭の宣言セクション内に記載

  1. ダウンロードURLからダウンロードするファイル名を取得し、保存ファイルパスを作成
  2. 念のため、キャッシュをクリアする
  3. 指定したファイルをダウンロードする
  4. 保存ファイルパスを返す

④「Update_NationalHolidayList」プロシージャ

  1. 「祝日リストシート」がない場合、シートを作成
  2. 「GetDownloadFilePath」を呼び出して、祝日データ用ファイルを取得
  3. FileSystemObjectのOpenAsTextStreamを使ってCSVデータを読込
  4. ダウンロードした祝日データ用ファイルを削除
  5. 祝日リストシートの表示形式を変更し、列幅を自動調整
  6. 祝日の日付一覧を「祝日リスト」として名前定義
ThisWorkbookモジュール

⑤「Workbook_SheetFollowHyperlink」イベントプロシージャ

  1. 念のため、Do～Loopを回して、ハイパーリンクが移動済みか確認
  2. 何らかの原因で移動していない場合、1秒後にマクロを終了させる
  3. 移動先にチェックが入っている場合、空白を入力し、ハイパーリンクを設定
  4. 移動先にチェックが入っていない場合、チェックを入れて、ハイパーリンクを設定
  5. クリックしたハイパーリンクが設定されているシートに戻る

カレンダーからハイパーリンクを実行した場合、予定一覧シートに移動した後、カレンダーシートに戻るため、どうしても画面がちらつく。SheetFollowHyperlinkイベントの起動より先に、予定一覧シートへ移動するので、Application.ScreenUpdating = Falseは効かなかった。そのため、あえて少し待ち、予定一覧にチェックを入れたことが分かるようにしている。

シートモジュール（予定一覧シート）

⑥「Worksheet_BeforeDoubleClick」イベントプロシージャ
予定一覧からカレンダーの該当する日付に移動できたら便利だなと思い、作成した。

  1. ダブルクリックしたセルが日付欄かつ日付データかどうかを確認
  2. ダブルクリックした日付の予定が上から何件目かを取得
  3. カレンダーシートがある場合、カレンダーシートの該当する日付を検索
  4. 見つかった日付の予定の位置を選択

注意点

  • 予定を追加・日付を変更した際には、Write_Calendarプロシージャを実行する必要がある
  • 日付以外の予定内容・時刻・備考の修正は、予定一覧シートで行えば、カレンダーシートはセル参照となっているため、反映される
  • 予定一覧をカレンダーへ書き込む仕様にしているが、以下のように、予定一覧を空欄のままリスト型のカレンダーにして、カレンダーシートを作成すれば、リスト型と月間表示型を連動させたカレンダーになる
    　
    予定一覧空欄.jpg

完成したマクロ

前提として、以下のイメージのように「予定一覧」シートに予定一覧が用意してあるとする。Write_Calendarプロシージャを実行することで、新規に「カレンダー」シートを追加し、以下のイメージのカレンダーを作成して、予定一覧を表示する。
また、Update_NationalHolidayListを実行すると、「祝日リスト」シートがない場合は、新規に作成、既にある場合は、新たな祝日データを追加する。

予定一覧シートのイメージ

予定一覧.jpg

作成されるカレンダーシートのイメージ

カレンダーサンプル.jpg

　

標準モジュール１
標準モジュール１：Write_Calendar
Public Sub Write_Calendar()

Dim i As Long
Dim j As Long
Dim k As Long
Dim endRow As Long
Dim TargetRange As Range
Dim RowCount As Long
Dim TargetDate As Date
Dim CalendarSheet As Worksheet
Dim myData As Collection
Dim myDataTable As Collection
Dim myTableCollection As Collection
Dim FindRange As Range
Dim TargetData As Collection
Dim TargetAddress As String

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    With ThisWorkbook.Sheets("予定一覧")
    
         '------- 予定一覧 並び替え -------
        endRow = .Cells(Rows.Count, "B").Row
        Set TargetRange = .Range(.Range("B2"), .Cells(endRow, "F"))       
        If WorksheetFunction.CountA(.Columns("B")) > 3 Then
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SortFields.Add Key:=.Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SetRange TargetRange
            With .Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End If
        
        '------- カレンダー行数調整用 日付件数取得 -------
        i = 3
        Set myDataTable = New Collection
        Do
            If IsDate(.Cells(i, "B").Value) Then
                If .Cells(i, "B").Value <> .Cells(i - 1, "B").Value Then
                    Set myData = New Collection
                    myData.Add .Cells(i, "B").Value, "日付"
                    myData.Add WorksheetFunction.CountIf(.Columns("B"), .Cells(i, "B").Value), "件数"
                    myDataTable.Add myData
                    Set myData = Nothing
                End If
            End If
            
            '予定一覧のチェック欄にハイパーリンクを設定
            If .Cells(i, "F").Value = .Range("F2").Value Then
                .Cells(i, "F").Hyperlinks.Add Anchor:=.Cells(i, "F"), Address:="", _
                    SubAddress:=.Cells(i, "F").Address, TextToDisplay:="=" & .Range("F2").Address, ScreenTip:="クリックしてください"
            Else
                .Cells(i, "F").Hyperlinks.Add Anchor:=.Cells(i, "F"), Address:="", _
                    SubAddress:=.Cells(i, "F").Address, TextToDisplay:="　　", ScreenTip:="クリックしてください"    
            End If
            i = i + 1
        Loop Until .Cells(i, "B").Value = ""

         '------- カレンダーシート作成 -------
        Set CalendarSheet = Create_CalendarSheet(CDate(myDataTable(1)(1)), CDate(myDataTable(myDataTable.Count)(1)))
        
        '行数調整
        For i = 1 To myDataTable.Count
            TargetDate = myDataTable(i)(1)
            Set FindRange = CalendarSheet.Cells.Find(What:=Format(TargetDate, "m月d日 aaa曜日"), LookIn:=xlValues, Lookat:=xlWhole)
            RowCount = FindRange.End(xlDown).Row - FindRange.Row - 1
            If RowCount < myDataTable(i)(2) Then
                For j = RowCount + 1 To myDataTable(i)(2)
                    FindRange.Offset(2).EntireRow.Copy
                    FindRange.Offset(2).EntireRow.Insert
                    Application.CutCopyMode = False
                Next j
            End If
        Next i
        Set myDataTable = Nothing
        
        '------- 予定を日付ごとにコレクション化 -------
        i = 3
        Set myTableCollection = New Collection
        Set myDataTable = New Collection
        Do
            If IsDate(.Cells(i, "B").Value) Then
                Set myData = New Collection
                myData.Add .Cells(i, "B").Value, "日付"
                myData.Add .Name, "シート名"
                myData.Add .Cells(i, "D").Address, "タスクアドレス"
                myData.Add .Cells(i, "C").Address, "時刻アドレス"
                myData.Add .Cells(i, "E").Address, "備考アドレス"
                myData.Add .Cells(i, "F").Address, "チェックアドレス"
                myDataTable.Add myData
                Set myData = Nothing
                
                If .Cells(i, "B").Value <> .Cells(i + 1, "B").Value Then
                    myTableCollection.Add myDataTable
                    Set myDataTable = Nothing
                    If .Cells(i + 1, "B").Value <> "" Then Set myDataTable = New Collection  
                End If
                
            End If
            i = i + 1
        Loop Until .Cells(i, "B").Value = ""
        
        '------- 予定をカレンダーに書き込み -------     
        For i = 1 To myTableCollection.Count
            TargetDate = myTableCollection(i)(1)("日付")
            Set FindRange = CalendarSheet.Cells.Find(What:=Format(TargetDate, "m月d日 aaa曜日"), LookIn:=xlValues, Lookat:=xlWhole)
            For j = 1 To myTableCollection(i).Count
                Set TargetData = myTableCollection(i)(j)
                For k = 3 To TargetData.Count
                    If k <> TargetData.Count Then
                        TargetAddress = TargetData("シート名") & "!" & TargetData(k)
                        FindRange.Offset(1).Cells(j, k - 2).Value = "=HYPERLINK(""#" & TargetAddress & """,if(" & TargetAddress & "="""",""""," & TargetAddress & "))"
                        FindRange.Offset(1).Cells(j, k - 2).Font.Color = rgbDarkBlue  '転記した予定の文字色
                        FindRange.Offset(1).Cells(j, k - 2).Font.Bold = True
                    Else
                         TargetAddress = TargetData("シート名") & "!" & TargetData(k)
                         FindRange.Offset(1).Cells(j, k - 2).Hyperlinks.Add _
                            Anchor:=FindRange.Offset(1).Cells(j, k - 2), _
                            Address:="", _
                            SubAddress:=TargetAddress, _
                            TextToDisplay:="=if(" & TargetAddress & "="""",""　""," & TargetAddress & ")", _
                            ScreenTip:="クリックしてください"
                    End If
                Next k
            Next j
        Next i
    End With

    '------- ハイパーリンクの書式変更（Hyperlink、Followed Hyperlink） -------
    For i = 1 To ThisWorkbook.Styles.Count
        If ThisWorkbook.Styles(i).Name Like "*Hyperlink" Then
            With ThisWorkbook.Styles(i).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
            End With
        End If
    Next i
 
    CalendarSheet.Protect
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub
標準モジュール１：Create_CalendarSheet
Public Function Create_CalendarSheet(StartDate As Date, EndDate As Date) As Worksheet

Dim CalendarSheetName As String
Dim ListSheet As Worksheet
Dim TargetSheet As Worksheet
Dim InsertRowCount As Long
    
    Set ListSheet = ThisWorkbook.Sheets("予定一覧")
    CalendarSheetName = "カレンダー"
    For Each TargetSheet In ThisWorkbook.Worksheets
        If TargetSheet.Name = CalendarSheetName Then
            Application.DisplayAlerts = False
            TargetSheet.Delete
            Application.DisplayAlerts = True
        End If
    Next TargetSheet

    Set TargetSheet = Sheets.Add(After:=ThisWorkbook.Sheets(1))
    
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.Zoom = 80
    TargetSheet.Name = CalendarSheetName
    
    TargetSheet.Range("B1").Value = DateSerial(Year(StartDate), Month(StartDate), 1)
    TargetSheet.Range("F1").Value = DateSerial(Year(EndDate), Month(EndDate), 1)
    TargetSheet.Range("B1", "F1").Font.Color = vbWhite
    
    TargetSheet.Range("B2:F2").Merge
    With TargetSheet.Range("B2")
        .Value = Format(StartDate, "yyyy年m月 ～ ") & Format(EndDate, "yyyy年m月")
        .Font.Size = 16
        .Font.Bold = True
        .HorizontalAlignment = xlHAlignLeft
    End With
 
    TargetSheet.Rows("1:1").RowHeight = 3
    TargetSheet.Rows("3:3").RowHeight = 3
    TargetSheet.Columns("A:A").ColumnWidth = 2

    With TargetSheet.Range("B3:E3")
        .Value = 1
        .Font.Color = vbWhite
    End With

    With Range("F3")
        .FormulaR1C1 = "=RC[-4]+1"
        .Font.Color = vbWhite
        .AutoFill Destination:=Range("F3:AC3"), Type:=xlFillDefault
    End With
    
    With TargetSheet.Range("B4")
        .FormulaR1C1 = "=R1C2+R[-1]C-WEEKDAY(R1C2,2)" 'WEEKDAY 種類:2 月曜始まり
        .NumberFormatLocal = "m""月""d""日 ""aaa""曜日"""   
    End With
    
    TargetSheet.Range("C4").Value = "＝" & ListSheet.Name & "!" & ListSheet.Range("C2").Address
    TargetSheet.Range("D4").Value = "＝" & ListSheet.Name & "!" & ListSheet.Range("E2").Address
    TargetSheet.Range("E4").Value = "＝" & ListSheet.Name & "!" & ListSheet.Range("F2").Address
  
    With TargetSheet.Range("B4:E7")
        .BorderAround xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
        .Borders(xlInsideVertical).Weight = xlHairline
        .ShrinkToFit = True
    End With
    
    'チェックを入れた場合の条件付き書式
    With TargetSheet.Range("B5:D7")
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=OFFSET($B5,0,(B$3-1)*4+3,1,1)=予定一覧!$F$2"
        .FormatConditions(1).Font.Color = rgbSilver
    End With
    
    '当日/土日/祝日セル部分の条件付き書式
    With TargetSheet.Range("B4:E4")
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=OFFSET($B4,0,(B$3-1)*4,1,1)=TODAY()"
        .FormatConditions(1).Interior.Color = rgbGold
        .FormatConditions.Add xlExpression, Formula1:="=COUNTIF(祝日リスト,OFFSET($B4,0,(B$3-1)*4,1,1))=1"
        .FormatConditions(2).Interior.Color = rgbMistyRose
        .FormatConditions.Add xlExpression, Formula1:="=WEEKDAY(OFFSET($B4,0,(B$3-1)*4,1,1),2)=6"
        .FormatConditions(3).Interior.Color = rgbAliceBlue
        .FormatConditions.Add xlExpression, Formula1:="=WEEKDAY(OFFSET($B4,0,(B$3-1)*4,1,1),2)=7"
        .FormatConditions(4).Interior.Color = rgbMistyRose
    End With

    TargetSheet.Range("C5:E7").HorizontalAlignment = xlCenter
    TargetSheet.Range("C5:C7").NumberFormatLocal = "h:mm;@"

    With TargetSheet.Range("B4:E4")
        .Font.Size = 12
        .Interior.Color = rgbLemonChiffon
        .HorizontalAlignment = xlCenter
        .BorderAround xlContinuous
    End With
    
    With TargetSheet
        .Range("B4:E7").Copy Range("B8")
        .Range("B8").FormulaR1C1 = "=R[-4]C+7"
        .Range("C8").FormulaR1C1 = "=R[-4]C"
        .Range("D8").FormulaR1C1 = "=R[-4]C"
        
        '既に最初の1週間分作成済みのため、-1で調整
        InsertRowCount = WorksheetFunction.RoundUp((DateAdd("m", 1, TargetSheet.Range("F1").Value) + 7 - TargetSheet.Range("B4").Value) / 7, 0) - 1
        
        .Range("A8:E11").AutoFill Destination:=.Range(.Range("A8"), Cells(8 + InsertRowCount * 4 - 1, "E")), Type:=xlFillDefault
        .Range(.Range("B4"), Cells(8 + InsertRowCount * 4 - 1, "E")).AutoFill Destination:=.Range(.Range("B4"), Cells(8 + InsertRowCount * 4 - 1, "AC")), Type:=xlFillDefault
        .Columns("B:AC").EntireColumn.AutoFit    
    End With
    
    Set Create_CalendarSheet = TargetSheet
    
End Function
　
標準モジュール２
標準モジュール２：GetDownloadFilePath
'ファイルダウンロード API宣言
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

'キャッシュ削除 API宣言
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" _
(ByVal lpszUrlName As String) As Long


Public Function GetDownloadFilePath(TragetURL As String) As String

Dim iFlag As Long

Dim SaveFilePath As String
Dim SaveFileName As String
  
    SaveFileName = Right(TragetURL, Len(TragetURL) - InStrRev(TragetURL, "/"))
    SaveFilePath = ThisWorkbook.Path & "\" & SaveFileName
    
    Call DeleteUrlCacheEntry(TragetURL) 'キャッシュクリア

    iFlag = URLDownloadToFile(0, TragetURL, SaveFilePath, 0, 0)
    
    If iFlag <> 0 Then MsgBox "ダウンロード失敗": End
    
    GetDownloadFilePath = SaveFilePath
    
End Function
標準モジュール２：Update_NationalHolidayList
Public Sub Update_NationalHolidayList()

Dim i As Long
Dim HolidaySheetName As String
Dim TargetSheet As Worksheet
Dim FSO As Object
Dim TargetYear As Long
Dim TargetFilePath As String
Dim TargetLine As Variant
Dim endRow As Long
Dim TargetRange As Range
Dim StartChar As Long

    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    HolidaySheetName = "祝日リスト"
    
    For i = 1 To ThisWorkbook.Worksheets.Count    
        If ThisWorkbook.Worksheets(i).Name = HolidaySheetName Then
            Set TargetSheet = ThisWorkbook.Worksheets(i)
            TargetYear = Year(WorksheetFunction.Max(TargetSheet.Columns(1))) + 1
        End If
    Next i
    
    'シートがない場合、新規作成
    If TargetSheet Is Nothing Then
        Set TargetSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        TargetSheet.Name = HolidaySheetName
        TargetSheet.Range("A1").Value = "日付"
        TargetSheet.Range("B1").Value = "名称"
        TargetYear = Year(Date) - 2
    End If
    
    TargetFilePath = GetDownloadFilePath("https://www8.cao.go.jp/chosei/shukujitsu/syukujitsu.csv")
    
    Set FSO = CreateObject("Scripting.FileSystemObject")  
    With FSO.GetFile(TargetFilePath).OpenAsTextStream
        Do
            TargetLine = Split(.ReadLine, ",")
            If Val(Left(TargetLine(0), 4)) >= TargetYear Then
                endRow = TargetSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                TargetSheet.Cells(endRow, "A").Value = TargetLine(0)
                TargetSheet.Cells(endRow, "B").Value = TargetLine(1)   
            End If
        Loop Until .AtEndOfStream
        .Close
    End With
    
    Set FSO = Nothing
    Kill TargetFilePath
    
    With TargetSheet
        .Columns("A:A").NumberFormatLocal = "yyyy/mm/dd (aaa) "
        .Columns("A:B").EntireColumn.AutoFit
        Set TargetRange = .Range(.Range("A1"), .Range("A1").End(xlDown))
        ThisWorkbook.Names.Add Name:="祝日リスト", RefersTo:="=" & Replace(TargetRange.Address(external:=True), "[" & ThisWorkbook.Name & "]", "")
    End With
    
    ThisWorkbook.Sheets(1).Activate
    Application.ScreenUpdating = True
    Application.EnableEvents = True
  
End Sub

　

ThisWorkbookモジュール
ThisWorkbookモジュール
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Dim TargetRange As Range
Dim StartTime As Date
        
        StartTime = Now
        
        If Target.ScreenTip = "クリックしてください" Then
        
            Do
                If ActiveCell.Address(External:=True) Like "*" & Target.SubAddress Then
                    
                    Set TargetRange = ActiveCell
                    
                    Exit Do
                
                End If
                
                If StartTime + TimeValue("0:00:01") < Now Then Exit Sub
                
            Loop
             
            If TargetRange.Value = ActiveSheet.Range("F2").Value Then
                
                TargetRange.Value = "　　"
                TargetRange.Hyperlinks.Add Anchor:=TargetRange, Address:="", _
                    SubAddress:=TargetRange.Address, ScreenTip:="クリックしてください"
                
            Else
                TargetRange.Value = "=" & ActiveSheet.Range("F2").Address
                TargetRange.Hyperlinks.Add Anchor:=TargetRange, Address:="", _
                    SubAddress:=TargetRange.Address, ScreenTip:="クリックしてください"
                
            End If
            
            If Sh.Name <> ActiveSheet.Name Then Application.Wait [Now()] + 600 / 86400000
            
            Sh.Select
         
        End If
 
End Sub

　

シートモジュール（予定一覧シート）
シートモジュール（予定一覧シート）
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim TargetNo As Long
Dim TargetSheetName As String
Dim TargetRange As Range
Dim mySheet As Worksheet
Dim myDic As Object

    If Cells(2, Target.Column).Value = "日付" And Target.Row > 2 And IsDate(Target.Value) Then

        TargetNo = Target.Row - WorksheetFunction.Match(CLng(Target.Value), Columns("B"), 0) + 1
        TargetSheetName = "カレンダー"
        
        Set myDic = CreateObject("Scripting.Dictionary")
        For Each mySheet In ThisWorkbook.Worksheets 
           myDic.Add mySheet.Name, mySheet.Name
        Next mySheet
            
        If myDic.exists(TargetSheetName) Then
        
            Sheets(TargetSheetName).Activate
            Set TargetRange = ActiveSheet.Cells.Find(What:=Format(Target.Value, "m月d日 aaa曜日"), LookIn:=xlValues, Lookat:=xlWhole)
            
            If TargetRange Is Nothing Then
                Cancel = True
                Exit Sub
            End If
            
            TargetRange.Offset(TargetNo).Select
            
        End If
        
        Cancel = True 
        
    End If
    
End Sub

サンプルファイル保存先：

更新履歴

2024/12/17：新規投稿
2024/12/18：祝日リストを作成し、カレンダーの祝日の色を変える部分を追加
　　　　　　 Write_Calendarプロシージャのハイパーリンクの書式変更部分を修正

5
1
2

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
5
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?