Excel VBA スケジュールマクロ最適化

質問

現在下記の様なスケジュール表を作成しています。
・セル(14,3)から下方は"タスク"列
・セル(14,5)から下方は"開始日"列
・セル(14,7)から下方は"終了日"列
・セル(14,8)から下方は"重要度"列
・セル(11,11)から右側へ日付が連番で入っている
・開始日と終了日を入れると自動的に変更された行を取得し、開始/終了日の範囲でセルの塗り潰しを実行
・重要度で色を変更し、"M"を入れると★マーク表示し、その右側へタスク名表示

３つ質問があります。
(1)現在、セルの塗り潰しを行うのに下記の様に設定しているのですが、日付を入れてからセルの塗り潰しがされるまで若干時間がかかるのですが、何か他に良い方法は無いでしょうか？
(2)あと、終了日の最大値を取得して、セル(11,11)から右側へ伸びている日付行を自動調整したいのですが、方法が分からなくて困っています。
(3)VBA初心者の為、色々調べながら作っているのですが、継ぎはぎだらけなので、改善したらよいポイントなどがあれば教えて頂けると助かります。

================================================================
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Gyo As Long
Dim COL As Long
Dim c As Integer
Dim l As Integer
Dim n As Integer

c = 11
l = 11

Gyo = Target.Row ' 変更した行を取得
If Gyo <= 13 Then Exit Sub ' 1～13なら無視
COL = Target.Column ' 変更した列を取得
If ((COL <= 4) Or (COL >= 9)) Then Exit Sub '開始日、終了日以外は無視
' 計算式セット自体でもイベントが発生するのでイベントを抑制
Application.EnableEvents = False

'入力した条件により、セルの塗りつぶし範囲を取得
If Cells(Gyo, 5) <= Cells(11, c) Then
Do Until Cells(Gyo, 5) >= Cells(11, c)
c = c + 1
Loop
ElseIf Cells(Gyo, 5) >= Cells(11, c) Then
Do Until Cells(Gyo, 5) <= Cells(11, c)
c = c + 1
Loop
End If

If Cells(Gyo, 7) <= Cells(11, l) Then
Do Until Cells(Gyo, 7) >= Cells(11, l)
l = l + 1
Loop
ElseIf Cells(Gyo, 7) >= Cells(11, l) Then
Do Until Cells(Gyo, 7) <= Cells(11, l)
l = l + 1
Loop
End If

'セルの色をクリア
Rows(Gyo).Interior.ColorIndex = xlNone

'セルの塗りつぶし範囲に色を設定
If Cells(Gyo, 8) = 1 Then
For n = c To l
Cells(Gyo, n).Clear
Cells(Gyo, n).Interior.ColorIndex = 3
Next n
ElseIf Cells(Gyo, 8) = 2 Then
For n = c To l
Cells(Gyo, n).Clear
Cells(Gyo, n).Interior.ColorIndex = 26
Next n
ElseIf Cells(Gyo, 8) = 3 Then
For n = c To l
Cells(Gyo, n).Clear
Cells(Gyo, n).Interior.ColorIndex = 5
Next n
ElseIf Cells(Gyo, 8) = "M" Then
Cells(Gyo, c) = "★"
Cells(Gyo, 3).Copy
Cells(Gyo, c + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(Gyo, 8).Select
Else
For n = c To l
Cells(Gyo, n).Clear
Cells(Gyo, n).Interior.ColorIndex = 10
Next n
End If
'イベントを再開
Application.EnableEvents = True
End Sub
============================================================

回答No.1

hige_082 · ベストアンサー

おはよう御座います
質問の（２）の自動調整ですが、終了日の最大値によって伸ばすだけでなく、短くもするのですか？
処理を重くするだけで、無駄なような気がします
期間を２ヶ月や３ヶ月と決めて、超えるものについては、期間の最終日か欄外に終了日を記入するようにしてはどうか

(1)と(3)については、変更・削除をしたので、確認してみてください

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Gyo As Long
Dim COL As Long
Dim Cli As Integer '<追加　セルの色用
Dim c As Integer
Dim l As Integer
Dim n As Integer

c = 11
l = 11

Gyo = Target.Row ' 変更した行を取得
If Gyo <= 13 Then Exit Sub ' 1～13なら無視
COL = Target.Column ' 変更した列を取得
'If ((COL <= 4) Or (COL >= 9)) Then Exit Sub '開始日、終了日以外は無視　'<変更1
If ((COL < 4) Or (COL > 9)) Then Exit Sub '開始日、終了日以外は無視　'<変更1　厳密化しただけ
' 計算式セット自体でもイベントが発生するのでイベントを抑制
Application.EnableEvents = False

'入力した条件により、セルの塗りつぶし範囲を取得
'If Cells(Gyo, 5) <= Cells(11, c) Then　'<削除
'Do Until Cells(Gyo, 5) >= Cells(11, c)　'<削除
'c = c + 1　'<削除
'Loop　'<削除
'ElseIf Cells(Gyo, 5) >= Cells(11, c) Then　'<変更2
If Cells(Gyo, 5) >= Cells(11, c) Then '<変更2　こちらの比較だけでよいように思う
'Do Until Cells(Gyo, 5) <= Cells(11, c)　'<変更3
'c = c + 1　'<変更3
'Loop　'<変更3
c = Cells(Gyo, 5) - Cells(11, c) + 11 '<変更3　計算で求めることが出来ます
Else '<追加
c = Cells(11, 11).End(xlToRight).Column '<追加　変更前の動作を維持するため
End If

'If Cells(Gyo, 7) <= Cells(11, l) Then　'<削除
'Do Until Cells(Gyo, 7) >= Cells(11, l)　'<削除
'l = l + 1　'<削除
'Loop　'<削除
'ElseIf Cells(Gyo, 7) >= Cells(11, l) Then　'<変更4
If Cells(Gyo, 7) >= Cells(11, l) Then '<変更4　こちらの比較だけでよいように思う
'Do Until Cells(Gyo, 7) <= Cells(11, l)　'<変更5
'l = l + 1　'<変更5
'Loop　'<変更5
l = Cells(Gyo, 7) - Cells(11, l) + 11 '<変更5　計算で求めることが出来ます
Else '<追加
l = Cells(11, 11).End(xlToRight).Column '<追加　変更前の動作を維持するため
End If

'セルの色をクリア
Cli = -4142 '<追加　xlNoneを数値化
'Rows(Gyo).Interior.ColorIndex = xlNone '<変更6
Rows(Gyo).Interior.ColorIndex = Cli '<変更6　色を変数で設定

'セルの塗りつぶし範囲に色を設定
'If Cells(Gyo, 8) = 1 Then '<変更7
Select Case Cells(Gyo, 8) '<変更7　IfをSerect Caseに変更、構文が短く、見やすい
Case 1
'For n = c To l '<変更8
'Cells(Gyo, n).Clear '<変更8
'Cells(Gyo, n).Interior.ColorIndex = 3 '<変更8
'Next n '<変更8
Cli = 3 '<追加　色を変数で設定
'ElseIf Cells(Gyo, 8) = 2 Then '<変更9
Case 2 '<変更9　IfをSerect Caseに変更したため
'For n = c To l '<変更8
'Cells(Gyo, n).Clear '<変更8
'Cells(Gyo, n).Interior.ColorIndex = 26 '<変更8
'Next n '<変更8
Cli = 26 '<追加　色を変数で設定
'ElseIf Cells(Gyo, 8) = 3 Then '<変更9
Case 3 '<変更9　IfをSerect Caseに変更したため
'For n = c To l '<変更8
'Cells(Gyo, n).Clear '<変更8
'Cells(Gyo, n).Interior.ColorIndex = 5 '<変更8
'Next n '<変更8
Cli = 5 '<追加　色を変数で設定
'ElseIf Cells(Gyo, 8) = "M" Then '<変更9
Case "M" '<変更9　IfをSerect Caseに変更したため
Cells(Gyo, c) = "★"
'Cells(Gyo, 3).Copy '<変更10
'Cells(Gyo, c + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '<変更10
'Application.CutCopyMode = False '<変更10
'Cells(Gyo, 8).Select '<変更10
Cli = -4142 '<追加　色を変数で設定
Cells(Gyo, c + 1) = Cells(Gyo, 3) '<変更10　書式は必要ないので値のみコピー
'Else '<変更9
Case Else '<変更9　IfをSerect Caseに変更したため
'For n = c To l '<変更8
'Cells(Gyo, n).Clear '<変更8
'Cells(Gyo, n).Interior.ColorIndex = 10 '<変更8
'Next n '<変更8
Cli = 10 '<追加　色を変数で設定
'End If '<変更9
End Select '<変更9　IfをSerect Caseに変更したため
For n = c To l '<変更8　ここに移動して、まとめて処理
Cells(Gyo, n).Clear '<変更8　ここに移動して、まとめて処理
Cells(Gyo, n).Interior.ColorIndex = Cli '<変更8　ここに移動して、まとめて処理
Next n
'イベントを再開
Application.EnableEvents = True
End Sub

お礼

早速のご回答ありがとうございました。
計算で求めたり、If文をSelect文にするなどされてて、構文がとても見やすくなりました。
頭の中がぐちゃぐちゃになっていたので、とても助かりました！

ただ、何故か"M"を入力しても★と文字が消えてしまうので、下記の２行をselect文の上に持って来させて頂きました。
For n = c To l '<変更8　ここに移動して、まとめて処理
Cells(Gyo, n).Clear '<変更8　ここに移動して、まとめて処理

質問(2)の自動調整は長くしたり短くしたりするつもりです。
（場合によっては数週間の予定であったり、数年の予定であったりするもので。。。）
ただ、処理が遅くなるとの事ですので、ボタンなどを追加して独立した処理をさせようと思います。

まだどの様に作るかモヤモヤしてる所ですが、hige_082様の構文で色々と勉強になる部分もあったので、また自分なりに考えて作ってみます。また分からない場合は質問させて頂きますので、宜しくお願いします。