よねさんのWordとExcelの小部屋 なんでも掲示板

HOME HELP 新規作成 新着記事 ツリー表示 トピック表示 検索 過去ログ

[ 最新記事及び返信フォームをトピックトップへ ]

■13362 / inTopicNo.1)  指定年月日からの横型の年間カレンダーを作成するの件
  
□投稿者/ ころてつ Mail -(2019/03/15(Fri) 01:19:32)
    よねさん

    お世話になります。ころてつというものです。
    よねさんのWordとExcelの小部屋でVBAを覚えている最中です。

    VBA実用編 指定年月日からの横型の年間カレンダーを作成する
    ですが、縦型のカレンダーにするのは簡単でしょうか?
    また項目セルも色塗りをしたいのです。

    やりたいことは

    D6・・1月 E6・・曜日 F6・・項目
    D7・・1  E7・・火  F7・・色塗りセル(祝土日であれば同じ色) 
    D8・・2  E8・・水  F8・・色塗りセル(祝土日であれば同じ色)
    D9・・3  E9・・木  F9・・色塗りセル(祝土日であれば同じ色)




    こんな風にできますか?
    よろしくお願いします。

引用返信/返信 削除キー/
■13363 / inTopicNo.2)  Re[1]: 指定年月日からの横型の年間カレンダーを作成するの件
□投稿者/ よねさん -(2019/03/15(Fri) 08:52:09)
    横型のカレンダーを縦型に変更してみました。
    ほとんど同じです。行が列に変更されていますので、その部分を注意してみていただければよろしいかと思います。
    
    カレンダーを作成するシートは カレンダー2
    祝祭日の一覧は 「祝日」シートのA1セルから縦に入力します。
    E2セルには 2019/1/1
    E3セルには =DATE(YEAR(E2)+1,MONTH(E2),DAY(E2)-1)
    O1セルには =TEXT(E3,"ggge")& "年度 カレンダー"
    と入力しています。
    
    コードの変更箇所は
    Dim retukan As Long, mycnt As Long
    retukan = 4  '列間隔
    
    ここから----
    '月、日にちを入力
    .Cells(6, retukan * i).Value = Month(.Cells(2, 5).Value) + i - 1 & "月"
    .Cells(6, retukan * i + 1).Value = "曜日"
    
    Set myPs = .Cells(6 + j, retukan * i)  '入力するセル ここを基準に設定しています
    ここまで----
    
    Offset(1,0)の箇所を↓のように Offset(0, 1) と数カ所を変更しています。
    myPs.Offset(0, 1).Value = Format(myDay, "aaa")
    
    といったところです。
    
    Sub calendar_tate()
    'カレンダー作成
    '
        Dim sh1 As Worksheet
        Dim i As Integer, j As Integer
        Dim myDay As Date
        Dim myPs As Range
        Dim Holiday As Range
        Dim iCol As Variant, fCol As Variant
        Dim myFlg As Boolean
        Dim sYear As Integer, eYear As Integer
        Dim sMonth As Integer, eMonth As Integer
        Dim sDay As Integer, eDay As Integer
         Dim retukan As Long, mycnt As Long
    
    
        Set sh1 = Worksheets("カレンダー2")
        Set Holiday = Worksheets("祝日").Range("A1:A84")
    
        Application.ScreenUpdating = False
      
        retukan = 4  '列間隔
    
        With sh1
            '着色クリア
            With .Range("D4:AW100")  'とりあえず100行目までを設定範囲として考えています。
                .ClearContents
                .Interior.ColorIndex = xlNone
                .Font.ColorIndex = 0
    
            End With
    
            '設定年月日
                sYear = Year(.Range("E2").Value)
                sMonth = Month(.Range("E2").Value)
                sDay = Day(.Range("E2").Value)
                eYear = Year(.Range("E3").Value)
                eMonth = Month(.Range("E3").Value)
                eDay = Day(.Range("E3").Value)
    
            For i = 1 To 12
                For j = 1 To 32
                    '入力する日付
                    myDay = DateSerial(sYear, sMonth - 1 + i, sDay - 1 + j)
    
                     'ループを抜ける条件
                      If Day(myDay) = sDay Then
                          mycnt = mycnt + 1
                              If mycnt = 2 Then
                                  mycnt = 0
                                  Exit For
                              End If
                      End If
    
                      '終了日になったら終了する
                      If myDay > DateSerial(eYear, eMonth, eDay) Then
                          Application.ScreenUpdating = True
                          End
                      End If
    
                    '月、日にちを入力
                    .Cells(6, retukan * i).Value = Month(.Cells(2, 5).Value) + i - 1 & "月"
                    .Cells(6, retukan * i + 1).Value = "曜日"
    
                    Set myPs = .Cells(6 + j, retukan * i)  '入力するセル ここを基準に設定しています
                    myPs.Value = myDay
                    myPs.NumberFormatLocal = "d"    '表示形式を"d"に設定しています。
    
                    '曜日を入力
                    myPs.Offset(0, 1).Value = Format(myDay, "aaa")
                    '土日check
                    myFlg = False
                    Select Case myPs.Offset(0, 1).Value
                        Case "土"
                            iCol = 34    '塗りつぶしの色番号
                            fCol = 5    'フォントの色番号
                            myFlg = True
                        Case "日"
                            iCol = 36
                            fCol = 3
                            myFlg = True
                        End Select
    
                      '祝日check
                      If WorksheetFunction.CountIf(Holiday, myPs.Value) = 1 Then
                          iCol = 40
                          fCol = 3
                          myFlg = True
                      End If
                      '着色  土日祝日の時(myFlg = True)に実行
                      If myFlg = True Then
                        .Range(myPs, myPs.Offset(0, 1)).Interior.ColorIndex = iCol
                        .Range(myPs, myPs.Offset(0, 1)).Font.ColorIndex = fCol
                      End If
    
                  Next j
    
                Next i
    
            End With
    
            Application.ScreenUpdating = True
    
    End Sub
    
    

引用返信/返信 削除キー/



トピック内ページ移動 / << 0 >>

このトピックに書きこむ

Pass/

HOME HELP 新規作成 新着記事 ツリー表示 トピック表示 検索 過去ログ

- Child Tree -