小川先生、お世話になっております。発展編フォローセミナーNo.29のカレンダー問題がようやく自分なりの解釈で何とか出来ました。
予習の意味で新しい構文を使ってみました。作り込む最中で色々なアイデアを試しながら出来、再発見、再確認ができました。
今回はいかに効率よく走るかを私なりに考えてつくりました。先生のご感想よろしくお願いします。先生のNO.29のメールからダウンロードしたファイルの中に、ControlのシートがなかったのでNO.26のファイルを使用して、祭日には、文字を赤、背景を黄色とする、前提条件としました。後で思ったのですが、
Summaryのシートにデータを入れるタイミングは１か月分が出来上がった段階で一気にそれをコピーした方がスピードが速いのではないかなと思いました。プログラムは出来上がりは同じでも課程はいろいろある所がじつに面白いですね。もっといろいろな構文、アルゴリズムを勉強すればさらにプログラミングの世界が広がる思うと、今後がたのしみです。上級編もまた、お願いしたいと思います。では、先生の感想をお待ちしております。
追伸。２０１５年のカレンダーにしました。

code

Dim dStart As Date, wNa As Integer
Dim list(6, 2) As Variant, sAijitu(16, 2) As Variant

Private Sub CalenCre()
CreMSht
dStart = #1/1/2015#
Dim mCnt As Long
Dim cOnws As Worksheet
Dim c As Integer
Set cOnws = Worksheets("Control")
With cOnws.Range("a2")
For c = 0 To 6
list(c, 0) = c + 1
list(c, 1) = .Offset(c).Interior.ColorIndex
list(c, 2) = .Offset(c).Font.ColorIndex
Next
End With
With cOnws.Range("c2")
For c = 0 To 16
sAijitu(c, 0) = .Offset(c).Value
sAijitu(c, 1) = .Offset(c).Interior.ColorIndex
sAijitu(c, 2) = .Offset(c).Font.ColorIndex
Next
End With
Worksheets("Summary").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "dami"
For mCnt = 1 To 12
Worksheets("dami").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = mCnt & "月"
calen_exe
dStart = DateAdd("m", 1, dStart)
Next
Application.DisplayAlerts = False
Worksheets("dami").Delete
Application.DisplayAlerts = True
Worksheets("Summary").Activate
End Sub

Public Sub calen_exe()
Dim dCnt As Date, sAicnt As Integer, mEmo
Dim c As Long, cYoko As Long, mAx As Long, yOucnt As Integer
Dim jyuS As String
Dim sH As Worksheet
Set sH = Worksheets("Summary")
Dim rg As Range
mAx = sH.Range("a" & Rows.Count).End(xlUp).Row
Set rg = sH.Range("a" & mAx + 1)
dCnt = dStart
c = 0
With Range("a2")
Do While Month(dCnt) = Month(dStart)
.Offset(c, 0).Value = dCnt
wNa = Weekday(dCnt)
.Offset(c, 1).Value = WeekdayName(wNa)
.Offset(c, 2).Value = #9:00:00 AM#
.Offset(c, 3).Value = #5:00:00 PM#
jyuS = "=" & .Offset(c, 3) & "-" & .Offset(c, 2).Value
.Offset(c, 4).Formula = jyuS
For cYoko = 0 To 4
rg.Offset(c, cYoko).Formula = "='" & .Worksheet.Name & "'!" & .Offset(c, cYoko).Address
Next
For sAicnt = mEmo To 16
If dCnt = sAijitu(sAicnt, 0) Then
With Range(rg.Offset(c, 0), rg.Offset(c, 4))
.Interior.ColorIndex = sAijitu(sAicnt, 1)
.Font.ColorIndex = sAijitu(sAicnt, 2)
End With
With Range(.Offset(c, 0), .Offset(c, 4))
.Interior.ColorIndex = sAijitu(sAicnt, 1)
.Font.ColorIndex = sAijitu(sAicnt, 2)
End With
mEmo = mEmo + 1
GoTo line1
End If
Next
For yOucnt = 0 To 6
If wNa = list(yOucnt, 0) Then
With Range(rg.Offset(c, 0), rg.Offset(c, 4))
.Interior.ColorIndex = list(yOucnt, 1)
.Font.ColorIndex = list(yOucnt, 2)
End With
With Range(.Offset(c, 0), .Offset(c, 4))
.Interior.ColorIndex = list(yOucnt, 1)
.Font.ColorIndex = list(yOucnt, 2)
End With
GoTo line1
End If
Next
line1:
dCnt = DateAdd("d", 1, dCnt)
c = c + 1
Loop
End With
End Sub

Public Sub CreMSht()
Dim wS As Worksheet
Dim orWs As Worksheet, nEwws As Worksheet, orCws As Worksheet
Set orWs = Worksheets("Summary")
Set orCws = Worksheets("Control")
Application.DisplayAlerts = False
For Each wS In Worksheets
If Not (wS Is orWs Or wS Is orCws) Then
wS.Delete
End If
Next
Application.DisplayAlerts = True
clean
End Sub

Public Sub clean()
Worksheets("Summary").Activate
Dim gyo As Long
gyo = Range("a" & Rows.Count).End(xlUp).Row
If gyo > 1 Then
With Range("a2", "e" & gyo)
.ClearContents
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
End With
End If
End Sub

/code

2015/09/02 08:12