回答の修正
http://q.hatena.ne.jp/1260079584
土曜日の不足分を修正しておきました。
過去に長いコードを回答欄に書いて表組が崩れたのは1回しかないのに、2回目が起きてしまいました。
Sub 表の作成() Dim myDate As Date Dim myDate2 As Date Dim myMonth As String Dim i As Integer Dim check As Boolean Dim check2 As Boolean Dim lastSun As Integer If Selection.Column <> 1 Then Exit Sub If IsDate(Selection.Value) Then myDate = Selection.Value Else Exit Sub End If myMonth = Month(myDate) '第5土曜日があるかどうかを判別 For i = 29 To 31 myDate2 = DateSerial(Year(myDate), Month(myDate), i) If Weekday(myDate2) = 7 And Month(myDate2) = myMonth Then check = True Exit For End If Next i '第5日曜日があるかどうかを判別 For i = 29 To 31 myDate2 = DateSerial(Year(myDate), Month(myDate), i) If Weekday(myDate2) = 1 And Month(myDate2) = myMonth Then check2 = True Exit For End If Next i If check2 Then lastSun = 5 Else lastSun = 4 End If i = 0 While Month(myDate) = myMonth Selection.Offset(i, 0).Value = myDate If Weekday(myDate) <> 1 Or (Weekday(myDate) = 1 And check = False And _ Int((Day(myDate) - 1) / 7) + 1 = lastSun) Then i = i + myMacro(Selection.Offset(i, 0)) End If myDate = myDate + 1 Wend End Sub Function myMacro(Target As Range) As Integer Dim myDate As Date Dim myDate2 As Date Dim res As Integer Dim check As Boolean res = 1 myDate = Target.Value Range(Cells(Target.Row, 3), Cells(Target.Row, 4)).Merge Target.Offset(0, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).ClearContents '曜日で分岐 Select Case Application.WorksheetFunction.Weekday(myDate) Case 1 '-----------------------------------------------------------------最終日曜 Target.Offset(0, 1).Value = "日" Target.Offset(0, 2).Value = "14:00" Target.Offset(0, 4).Value = "19:00" Target.Offset(0, 5).Value = "5:00" Target.Offset(0, 6).Value = "移動介助" Target.Offset(0, 7).Value = "みのり様" Target.Offset(0, 8).Value = "家" Target.Offset(0, 12).Value = "移動支援" Case 2 '-----------------------------------------------------------------月曜1回目 Target.Offset(0, 1).Value = "月" Target.Offset(0, 2).Value = "20:00" Target.Offset(0, 4).Value = "20:30" Target.Offset(0, 5).Value = "0:30" Target.Offset(0, 6).Value = "移動介護" Target.Offset(0, 7).Value = "みのり様" Target.Offset(0, 8).Value = "家" Target.Offset(0, 9).Value = "⇔" Target.Offset(0, 10).Value = "レンタルショップ" Target.Offset(0, 11).Value = "徒歩" Target.Offset(0, 12).Value = "移動支援" Range(Cells(Target.Row + 1, 3), Cells(Target.Row + 1, 4)).Merge Target.Offset(1, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 1, 1), Cells(Target.Row + 1, 13)).ClearContents '-----------------------------------------------------------------月曜2回目 Target.Offset(1, 0).Value = Target.Value Target.Offset(1, 1).Value = "月" Target.Offset(1, 2).Value = "20:30" Target.Offset(1, 4).Value = "21:00" Target.Offset(1, 5).Value = "0:30" Target.Offset(1, 6).Value = "身体介護" Target.Offset(1, 7).Value = "みのり様" Target.Offset(1, 12).Value = "居宅介護" res = 2 Case 3 '-----------------------------------------------------------------火曜 Target.Offset(0, 1).Value = "火" Target.Offset(0, 2).Value = "18:30" Target.Offset(0, 4).Value = "19:30" Target.Offset(0, 5).Value = "1:00" Target.Offset(0, 6).Value = "身体介護" Target.Offset(0, 7).Value = "森田ケアーズ蔵前様" Target.Offset(0, 12).Value = "居宅介護" Case 4 '-----------------------------------------------------------------水曜 Target.Offset(0, 1).Value = "水" Target.Offset(0, 2).Value = "18:30" Target.Offset(0, 4).Value = "19:30" Target.Offset(0, 5).Value = "1:00" Target.Offset(0, 6).Value = "身体介護" Target.Offset(0, 7).Value = "あやの実ヘルパーステーション様" Target.Offset(0, 12).Value = "居宅介護" Case 5 '-----------------------------------------------------------------木曜 Target.Offset(0, 1).Value = "木" Target.Offset(0, 2).Value = "18:30" Target.Offset(0, 4).Value = "19:30" Target.Offset(0, 5).Value = "1:00" Target.Offset(0, 6).Value = "身体介護" Target.Offset(0, 7).Value = "支援センター様" Target.Offset(0, 12).Value = "居宅介護" Case 6 '-----------------------------------------------------------------金曜1回目 Target.Offset(0, 1).Value = "金" Target.Offset(0, 2).Value = "18:30" Target.Offset(0, 4).Value = "20:00" Target.Offset(0, 5).Value = "1:30" Target.Offset(0, 6).Value = "移動介護" Target.Offset(0, 7).Value = "森田ケアーズ蔵前様" Target.Offset(0, 8).Value = "家" Target.Offset(0, 10).Value = "松が谷福祉会館" Target.Offset(0, 11).Value = "徒歩" Target.Offset(0, 12).Value = "移動支援" Range(Cells(Target.Row + 1, 3), Cells(Target.Row + 1, 4)).Merge Target.Offset(1, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 1, 1), Cells(Target.Row + 1, 13)).ClearContents '-----------------------------------------------------------------金曜2回目 Target.Offset(1, 0).Value = Target.Value Target.Offset(1, 1).Value = "金" Target.Offset(1, 2).Value = "22:00" Target.Offset(1, 4).Value = "23:30" Target.Offset(1, 5).Value = "1:30" Target.Offset(1, 6).Value = "身体介護" Target.Offset(1, 7).Value = "森田ケアーズ蔵前様" Target.Offset(1, 12).Value = "居宅介護" res = 2 Case 7 '-----------------------------------------------------------------土曜第共通1回目 Target.Offset(0, 1).Value = "土" Target.Offset(0, 2).Value = "13:00" Target.Offset(0, 4).Value = "15:00" Target.Offset(0, 5).Value = "2:00" Target.Offset(0, 6).Value = "身体介護" Target.Offset(0, 7).Value = "あやの実ヘルパーステーション様" Target.Offset(0, 12).Value = "居宅介護" Range(Cells(Target.Row + 1, 3), Cells(Target.Row + 1, 4)).Merge Target.Offset(1, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 1, 2), Cells(Target.Row + 1, 13)).ClearContents '第何週かで分岐 Select Case Int((Day(myDate) - 1) / 7) + 1 Case 1 '-----------------------------------------------------------------土曜第1週2回目 Target.Offset(1, 0).Value = Target.Value Target.Offset(1, 1).Value = "土" Target.Offset(1, 2).Value = "16:30" Target.Offset(1, 4).Value = "19:00" Target.Offset(1, 5).Value = "2:30" Target.Offset(1, 6).Value = "移動介助" Target.Offset(1, 7).Value = "森田ケアーズ蔵前様" Target.Offset(1, 12).Value = "移動支援" Range(Cells(Target.Row + 2, 3), Cells(Target.Row + 2, 4)).Merge Target.Offset(2, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 2, 2), Cells(Target.Row + 2, 13)).ClearContents '-----------------------------------------------------------------土曜第1週3回目 Target.Offset(2, 0).Value = Target.Value Target.Offset(2, 1).Value = "土" Target.Offset(2, 2).Value = "21:00" Target.Offset(2, 4).Value = "23:30" Target.Offset(2, 5).Value = "2:30" Target.Offset(2, 6).Value = "移動介助" Target.Offset(2, 7).Value = "森田ケアーズ蔵前様" Target.Offset(2, 12).Value = "移動支援" res = 3 Case 2 '-----------------------------------------------------------------土曜第2週2回目 Target.Offset(1, 0).Value = Target.Value Target.Offset(1, 1).Value = "土" Target.Offset(1, 2).Value = "16:00" Target.Offset(1, 4).Value = "17:30" Target.Offset(1, 5).Value = "1:30" Target.Offset(1, 6).Value = "移動介助" Target.Offset(1, 7).Value = "森田ケアーズ蔵前様" Target.Offset(1, 12).Value = "移動支援" Range(Cells(Target.Row + 2, 3), Cells(Target.Row + 2, 4)).Merge Target.Offset(2, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 2, 2), Cells(Target.Row + 2, 13)).ClearContents '-----------------------------------------------------------------土曜第2週3回目 Target.Offset(2, 0).Value = Target.Value Target.Offset(2, 1).Value = "土" Target.Offset(2, 2).Value = "19:30" Target.Offset(2, 4).Value = "21:30" Target.Offset(2, 5).Value = "2:00" Target.Offset(2, 6).Value = "移動介助" Target.Offset(2, 7).Value = "森田ケアーズ蔵前様" Target.Offset(2, 12).Value = "移動支援" Range(Cells(Target.Row + 3, 3), Cells(Target.Row + 3, 4)).Merge Target.Offset(3, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 3, 2), Cells(Target.Row + 3, 13)).ClearContents '-----------------------------------------------------------------土曜第2週の翌日 Target.Offset(3, 0).Value = Target.Value + 1 Target.Offset(3, 1).Value = "日" Target.Offset(3, 2).Value = "21:30" Target.Offset(3, 4).Value = "23:00" Target.Offset(3, 5).Value = "1:30" Target.Offset(3, 6).Value = "移動介助" Target.Offset(3, 7).Value = "森田ケアーズ蔵前様" Target.Offset(3, 8).Value = "手話サークル" Target.Offset(3, 10).Value = "家" Target.Offset(3, 11).Value = "日比谷線千代田線" Target.Offset(3, 12).Value = "移動支援" res = 4 Case 3, 4 '-----------------------------------------------------------------土曜第3・4週2回目 Target.Offset(1, 0).Value = Target.Value Target.Offset(1, 1).Value = "土" Target.Offset(1, 2).Value = "16:30" Target.Offset(1, 4).Value = "18:30" Target.Offset(1, 5).Value = "2:00" Target.Offset(1, 6).Value = "移動介助" Target.Offset(1, 7).Value = "森田ケアーズ蔵前様" Target.Offset(1, 12).Value = "移動支援" Range(Cells(Target.Row + 2, 3), Cells(Target.Row + 2, 4)).Merge Target.Offset(2, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 2, 2), Cells(Target.Row + 2, 13)).ClearContents '-----------------------------------------------------------------土曜第3・4週3回目 Target.Offset(2, 0).Value = Target.Value Target.Offset(2, 1).Value = "土" Target.Offset(2, 2).Value = "20:30" Target.Offset(2, 4).Value = "23:00" Target.Offset(2, 5).Value = "2:30" Target.Offset(2, 6).Value = "移動介助" Target.Offset(2, 7).Value = "森田ケアーズ蔵前様" Target.Offset(2, 12).Value = "移動支援" Range(Cells(Target.Row + 3, 3), Cells(Target.Row + 3, 4)).Merge Target.Offset(3, 2).HorizontalAlignment = xlCenter Range(Cells(Target.Row + 3, 2), Cells(Target.Row + 3, 13)).ClearContents '-----------------------------------------------------------------土曜第3・4週の翌日 Target.Offset(3, 0).Value = Target.Value + 1 Target.Offset(3, 1).Value = "日" Target.Offset(3, 2).Value = "21:00" Target.Offset(3, 4).Value = "23:00" Target.Offset(3, 5).Value = "2:00" Target.Offset(3, 6).Value = "移動介助" Target.Offset(3, 7).Value = "森田ケアーズ蔵前様" Target.Offset(3, 8).Value = "手話サークル" Target.Offset(3, 10).Value = "家" Target.Offset(3, 11).Value = "日比谷線千代田線" Target.Offset(3, 12).Value = "移動支援" res = 4 Case 5 '-----------------------------------------------------------------土曜第5週2回目 Target.Offset(1, 0).Value = Target.Value Target.Offset(1, 1).Value = "土" Target.Offset(1, 2).Value = "16:30" Target.Offset(1, 4).Value = "21:30" Target.Offset(1, 5).Value = "5:00" Target.Offset(1, 6).Value = "移動介助" Target.Offset(1, 7).Value = "みのり様" Target.Offset(1, 12).Value = "移動支援" '第5土曜だけは前行を上書き Target.Offset(0, 7).Value = "みのり様" res = 2 End Select End Select myMacro = res End Function