EXCEL VBA で年間カレンダーを作成したい

Question

EXCEL VBAで年間カレンダーを作りたいのでご教示下さい。
①コードをすっきりさせたい（処理を早くしたい）②表示の各月を“1月”、“2月”と表示させたい
③（次処理別コード）
　カレンダー作成後に各月の休日に手動で黄色を付ける。※稼働日（白セル）、休日（黄色セル）
　　その後に各月の稼働日（白セル）、休日（黄色セル）の数をカウントしたあと
（稼働日と休日を表示）
セルB41に1月、B42に2月、B43に3月、B44に4月、B45に5月、B46に6月、J41に7月、J42に8月、J43に9月、J44に10月、J45に11月、J46に12月、R41に各月の稼働日合計と休日合計を表示

（検索して見つけたコードとマクロの記録と途中のコード）（記載できるところまで）
Sub cal()
 '横に3か月、下に4か月を出力
    Dim myDate As Integer
    Dim Nen As Integer, Tuki As Integer
    Dim i As Integer, j As Long, k As Integer
    Dim myTitleD, myTitle(1 To 1, 1 To 7)
    Dim myRow As Integer, myCol As Integer
    Dim cn As Long, cntCol As Integer, cntRow As Integer
    Dim c As Range
        Worksheets("Sheet1").Activate
       With Range("A1:Z49")
            .Font.Size = 28
            .Font.Name = "メイリオ"
            .Font.Bold = True
        End With

        myRow = 9
        myCol = 8
        
        myDate = Application.InputBox(Title:="年の指定", _
                            Prompt:="作成する年（西暦）を入力してください", _
                            Default:="2019", Type:=1)
        Nen = myDate
        
        myTitleD = Array("日", "月", "火", "水", "木", "金", "土")
        For k = 0 To 6
            myTitle(1, k + 1) = myTitleD(k)
        Next k
        
                Application.ScreenUpdating = False


        Worksheets("Sheet1").Activate

        For i = 1 To 12
            Dim myTable(1 To 6, 1 To 7)
            cn = 1
            
             Select Case i
                Case 1, 4, 7, 10
                    cntCol = 1
                Case 2, 5, 8, 11
                    cntCol = 2
                Case 3, 6, 9, 12
                    cntCol = 3
            End Select
            Select Case i
                Case 1 To 3
                    cntRow = 1
                Case 4 To 6
                    cntRow = 2
                Case 7 To 9
                    cntRow = 3
                Case 10 To 12
                    cntRow = 4
            End Select
For j = DateSerial(Nen, i, 1) To DateSerial(Nen, i + 1, 0)
                If Day(j) <> 1 And Weekday(j) = 1 Then cn = cn + 1
                myTable(cn, Weekday(j)) = j
            Next j
            
             With Cells(5 + myRow * (cntRow - 1), 4 + myCol * (cntCol - 1))
                If i = 1 Then .Offset(0, -1).Value = Nen
                .Value = i
                .Font.Bold = True
                .Offset(1, 0).Resize(1, 7).Value = myTitle
                .Offset(2, 0).Resize(6, 7).Value = myTable
                
                .Offset(1, 0).Resize(1, 7).Interior.Color = RGB(194, 214, 154)
                .Offset(1, 0).Resize(6, 7).HorizontalAlignment = xlCenter
                .Offset(2, 0).Resize(6, 7).NumberFormatLocal = "d"
                
                .Offset(1, 0).Resize(7, 1).Font.Color = RGB(255, 0, 0)

            End With
            Erase myTable
        Next i

      
Worksheets("Sheet1").Activate

        Range("A:B").Delete

        Application.ScreenUpdating = True

        Worksheets("Sheet1").Activate
        Range("A5").Select
     Cells.EntireColumn.AutoFit
    Range("A5").Select
    Selection.Cut Destination:=Range("B1")

    Range("B1:X1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False

    End With
    Selection.Merge
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

    Application.Calculation = xlCalculationManual


    Selection.NumberFormatLocal = "0""年 カレンダー"""
    Range("B3:X3").Select
    With Selection

WindFaller · Accepted Answer

一応、なにかの参考にと思い、「マクロで作るカレンダー」を、私も作ってみました。
作ってみて気がついたことは、今回のようなマクロは、ボタン起動型よりも、アドイン型のほうが利便性が高かったのですが、それでも、ボタンの付け方とか、別の意味で参考になるだろうと思いました。ご要望になっているものとは、違いますが、3列と2列の選択、月曜日スタート型と、日曜日スタート型とか、曜日を日本か英語か選べるようになっています。

http://xfs.jp/YRT1C
ダウンロード後は、プロパティからブロックを外してください。

WindFaller · Answer

こんばんは。
遅くなってすみません。

以下は、仮に書いたマクロです。
3つの色を回すには、Mod演算子で、余りを見ればよいでしょう。

私は、RGBの時は、一回、Long型の数字にしてしまいます。
ただ、私の場合は、長くなるのを嫌い、16進にしてしまいます。
ただ、やはりColorIndexのほうが簡単です。

Sub ChangeColorRGB()
Dim arColors As Variant
Dim myYear As Long
Dim i As Long
arColors = Array("8000", "FFFF", "FF00FF") 'RGB型 '順に、緑・黄色・ピンク
 myYear = 2021
 i = myYear Mod 3
 With ActiveCell
　.Value = myYear
   .Font.Color = CLng("&H" & arColors(i))
 End With
End Sub
-----------------------
Sub ChangeColor()
Dim arColors As Variant
Dim myYear As Long
arColors = Array(10, 6, 7) '順に、緑・黄色・ピンク
 myYear = 2022
 i = myYear Mod 3
  With ActiveCell
　.Value = myYear
   .Font.ColorIndex = arColors(i)
 End With
End Sub
---------------------

WindFaller · Answer

No.5の補足です。
大事なことを書き忘れていました。

If .Cells(i).Value > 100 Then
　If .Cells(i).Interior.ColorIndex = 6 Or _
　  .Cells(i).Font.ColorIndex = 3 Or _
　  .Cells(i).DisplayFormat.Font.ColorIndex = 3 Then
　  cnt0 = cnt0 + 1

なぜ、ColorIndex を使うかというと、私の勘違いでなければ、RGBの比較ですと、うまくいかないことが多いのです。もちろん、型もLong型どうしの比較をしなければならないこともあります。
それに比較すると、ColorIndex というのは、RGBに対して、一種の丸目（四捨五入のようなもの）がなされるそうです。丸目た数字どうしで比較すれば、案外失敗は少ないはずです。

If .Cells(i).Value > 100 Then
私の作ったカレンダーの場合は、日・月・火……は、文字列ではなく書式の{aaa}で曜日を表す関係で、10以下の数字で表示させています。

なお、事実上、年に一回のマクロというのは、よほど作りこみしないと、とても実用の目途など立ちません。私自身で作ったものは、これでよいという見極めがつかないのです。

WindFaller · Answer

こんにちは。
>③
リスト化でも、その中身を拾い上げるには、ちょっと手間が掛かりすぎます。
数だけにさせていただきます。
「R41に各月の稼働日合計と休日合計を表示」
レイアウトとしては、B7から始まること。色づけは、この中にはは出てきませんでしたが、条件付き書式の赤字を加えました。

フォントの赤字、塗りつぶしの黄色、条件付き書式の赤字の三種

Sub CountDates()
Dim x As Long, y As Long
Dim i As Long, j As Long
Dim ar, biz As Long, res As Long

Cells(40, 2).Resize(, 2).Value = Array("稼働日", "休日")
Cells(40, 11).Resize(, 2).Value = Array("稼働日", "休日")

For y = 0 To 3
 For x = 0 To 2
   With Cells(y * 9 + 7, x * 8 + 2)
　ar = colorCount(Intersect(.CurrentRegion, .CurrentRegion.Offset(2)))
   End With
 
   j = j + 1
   Cells(i + 41, 1 + Int(j / 7) * 9).Value = j & "月"
   Cells(i + 41, 2 + Int(j / 7) * 9).Value = ar(0)
   Cells(i + 41, 3 + Int(j / 7) * 9).Value = ar(1)
   i = i + 1
   biz = biz + ar(0)
   res = res + ar(1)
   If j = 6 Then i = 0
 Next
Next
 Range("R40").Value = Array("稼働日合計", "休日合計")
 Range("R41").Resize(, 2).Value = Array(biz, res)
End Sub

Function colorCount(rng As Range)
Dim cnt0 As Long
Dim cnt1 As Long
Dim i As Long, j As Long
With rng
 For i = 1 To .Cells.Count
   If .Cells(i).Value > 100 Then
　If .Cells(i).Interior.ColorIndex = 6 Or _
　  .Cells(i).Font.ColorIndex = 3 Or _
　  .Cells(i).DisplayFormat.Font.ColorIndex = 3 Then
　  cnt0 = cnt0 + 1
　Else
　  cnt1 = cnt1 + 1
　End If
   End If
 Next
End With
 colorCount = Array(cnt1, cnt0) '稼働日,休日
End Function

WindFaller · Answer

こんにちは。
少し割り込ませていただきます。

もう、ほとんど出来上がっていますから、ご自身で最後まで出来るのではないかと思いますが、
いまさらという気にもなりますが、初歩的な問題が、なぜ、点々と現れているのか、というぐらいです。

実際問題、年に一度しか使わないなら、マクロは作らないほうが良い、というのは、老婆心かもしれません。会社では、No.2さんのご指摘には当たらない立場の方のようですが、過去の私自身や私の同僚や友人を含めて、No.2さんのアドバイスは本当に身にしみます。マクロのバグの修正は、自分の『足下を暗くする』ということです。

あくまでも、プライベートでマクロの練習としてなさっている方という前提で、少し、コメントを述べさせていただきます。練習用マクロとしては、なかなか面白いものだと思います。

それを実用にまで昇華させるには、色づけ、レイアウトなどの肉付けの際は、このマクロ群を、分散化したほうがよいです。一本で作ると、失敗した時に、手がつけられなくなる恐れがあります。
＊＊＊＊
a)
すでにご指摘にもありますが、Worksheets("Sheet1").Activate　が何度か登場していますが、最初の1度だけで十分です。ただし、それは、Worksheets("Sheet1").Select です。Activate の意味はご存じですか？複数選択していても、そのシートを一番上の加工を可能にするという意味で、Select とは似ていますが、似ていて違うものです。

b)
>Application.Calculation = xlCalculationManual
これは今回、ほとんど意味がありません。入れるなら、プログラムの最初に入れます。

c)
Range("B1:X1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
・
・
こういうところは、マクロでは、変更するに必要なものだけを書きます。

With Range("B1:X1")　　
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
d)
myDate = Application.InputBox
InputBox は、ESCキーなど離脱の選択肢をもうけたほうがよいです。

Default:="2019"
ここは、Year(Now) + 1
 にしてもよいでしょう。

e)
For i = 1 To 12
Dim myTable(1 To 6, 1 To 7)
cn = 1
VBAでは、このような書き方はしません。実行中の中では、Redim を使うことが多いです。

ざっとこんなところですが、もし時間があるようでしたら、私も試しに作ってみたいと思いました。以前から、やってみたいと思いましたが、実際、カレンダーは、Microsoft のテンプレートから探すというのがいつもだからです。

なお、
>②表示の各月を“1月”、“2月”と表示させたい

.Value = i
 With Cells(5 + myRow * (cntRow - 1), 4 + myCol * (cntCol - 1))
  If i = 1 Then .Offset(0, -1).Value = Nen
   .Value = i &"月" ←ここ　64行目前後
（実際、マクロを走らせていないので、不具合があるかもしれません。)

以上です。

satoumasaru · Answer

No2 です。

それでは私が気がついたところを四点ばかり書かせていただきます。
・VBAの場合は、Rangeを使用するのは最小限にしてCellsを使用する方が使い勝手がよいです。
・Activate はVBAならば使用する必要はありません。そのつどワークシートをActivateにしていればスピードは遅くなります。
・書式設定には時間がかかります。セル単位で指定するのではなく、すべてワークシートを完成させてから書式設定された方がよいです。
・Case 文は複数の命令を書くことができます。その方が見通しがよくなります。
　　Case 1
　　　cntCol = 1　：cntRow = 1
　　Case 2
        ……
他にもいろいろあると思いますが、私の気のついたところです。

satoumasaru · Answer

エクセルVBAの初心者です。

普通に関数と条件付き書式だけで万年カレンダーはできるとおもいますけれど……
誤操作を防ぐためには、シートを保護すればよい話だと思いますよ。

VBAに限らずプログラムで作成したら、後のメンテナンスは大変ですよ。
何か変更があったら、その都度作成者が呼び出されます。
ユーザーの誤操作でストップしたら、もうすぐにヘルプ電話がかかってきます。
感謝されることはすくなく、動いてあたりまえ、ちゃんと動かないものをつくった奴が悪いとなります。

保守する方も作成当初はロジックを覚えているのですがいくつか前のものだと解析からはじめなければなりません。
時間がとられて本業はできないし、いくら言っても理解してもらえないし…

くんこば · Answer

ここに書かれてること、普通に関数だけで組めると思うけど、VBAでないとダメなの？
ひな形作っといてVBAでコピー作って、の方が断然早いけど。

EXCEL VBA で年間カレンダーを作成したい

一応、なにかの参考にと思い、「マクロで作るカレンダー」を、私も作ってみました。

こんばんは。

No.5の補足です。

こんにちは。

こんにちは。

No2 です。

エクセルVBAの初心者です。

ここに書かれてること、普通に関数だけで組めると思うけど、VBAでないとダメなの？

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング