livedoor ナレッジ

シートコピーのVBAでもっと早くならないか考えております。どなたか見てください

Private Sub ShtCopy1(土井シート, yr)

   Shtname1 = 土井シート.Name & yr
   
   'あれば作らない
   For Each Sht1 In Worksheets
       If Sht1.Name = Shtname1 Then Exit Sub
   Next
   
   '無ければ作る
   土井シート.Copy Before:=土井シート
   ActiveSheet.Name = Shtname1

End Sub

Private Sub ShtCopy2(井戸シート, yr)

   Shtname2 = 井戸シート.Name & yr
   
   'あれば作らない
   For Each Sht2 In Worksheets
       If Sht2.Name = Shtname2 Then Exit Sub
   Next
   
   '無ければ作る
   井戸シート.Copy Before:=井戸シート
   ActiveSheet.Name = Shtname2

End Sub

Sub シート作成()

   Set Org土井 = Worksheets("土井")
   Call ShtCopy1(Org土井, Year(Date) - 2)
   Call ShtCopy1(Org土井, Year(Date) - 1)
   Call ShtCopy1(Org土井, Year(Date))
   Call ShtCopy1(Org土井, Year(Date) + 1)
   
   Set Org井戸 = Worksheets("井戸")
   Call ShtCopy2(Org井戸, Year(Date) - 2)
   Call ShtCopy2(Org井戸, Year(Date) - 1)
   Call ShtCopy2(Org井戸, Year(Date))
   Call ShtCopy2(Org井戸, Year(Date) + 1)
   
   '不要シートの削除
   For Each Sht1 In Worksheets
       If Sht1.Name = ("土井") & (Year(Date) - 3) Then
           Application.DisplayAlerts = False
           Sht1.Delete
           Application.DisplayAlerts = True
       End If
   Next
   
   For Each Sht2 In Worksheets
       If Sht2.Name = ("井戸") & (Year(Date) - 3) Then
           Application.DisplayAlerts = False
           Sht2.Delete
           Application.DisplayAlerts = True
       End If
   Next

１．CALLを全て外す。
　　プロシージャ名だけで、呼び出せるので
　　外す。

   CALL文の解釈をしなくて済むので。

２．何回も出てくる文は、まとめる。
　　具体的には、Year(Date) は、事前にyyyy
　　などの変数に代入しておいて、
　　yyyy-2,yyyy-1,yyyy,yyyy+1を使う。

   year関数の解釈をせず、変数を参照させる。

３．Application.DisplayAlerts = Trueは、外す。
　　マクロが終了すれば、自動的にTrueになります。