Worksheet_BeforeDoubleClickのプロシージャが大きすぎます

vba初心者です。
教えていただけると助かります。
'ボタン2押す→L44～AU51斜線
Private Sub CommandButton2_Click()
ActiveSheet.Shapes.AddLine(Range("L44").Left, Range("L44").Top, Range("AU51").Left + Range("AU51").Width, Range("AU51").Top + Range("AU51").Height).Select
ActiveSheet.Shapes.AddLine(70.75, 546.5, 89.75, 546.5).Select
ActiveSheet.Shapes.AddLine(70.75, 557.5, 89.75, 557.5).Select
End Sub

'ダブルクリック
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim myRange As Range
Dim myTarget As Range
Dim sp As Shape
Dim sp2 As Shape

Set myRange = Union(Range("B16:B226"), Range("G21:G43"), Range("AV16:AY226"), Range("K36:K40"), _
Range("L92"), Range("O25:O204"), Range("R208:R209"), Range("T36:Z37"), _
Range("AK22:AQ29"), Range("V23:AA30"), Range("AM50:AQ57"), Range("AJ63:AL64"), _
Range("AQ98:AQ106"), Range("AT102"), Range("Y101:AE101"), Range("AB103:AF103"), _
Range("AD147:AJ147"), Range("AB149:AF149"), Range("U170:AB170"), Range("T191:Y191"), _
Range("AM192:AQ194"), Range("U197:AB197"), Range("W208"), Range("AB208:AB209"), Range("K36:K39"), _
Range("L92"), Range("Y108:AN108"), Range("AC104"), Range("Q105:AD105"), Range("AE106"))

If Intersect(Target, myRange) Is Nothing Then Exit Sub

Set myTarget = Target.Offset(0, 0)
Select Case myTarget.Address(0, 0)

Case "B18"
For Each sp In ActiveSheet.Shapes
If sp.Name = Target.Address Then
sp.Delete
Range("AV18:AY18") = ""
Range("AW18") = "－"
Range("AY18") = "－"
Exit Sub
・
・
・
・
・
End Select

Target.Offset(0, 0).Select
Cancel = True

End Sub

・・・・・欄は、同じ様なCase""～Exit Subが連なります
同じ様なんですが、微妙に違うため、
Case""がRangeの数ぶん続きます。

Excel2013では問題なく（問題はあるとは思いますが）、動きます。

Excel2010以前だとプロシージャが大きすぎます。と出て、
使用することが出来ません。

前のExcelでも使える様にしたいのですが、どうしたらいいでいいでしょうか。
アドバイスいただけると助かります。

No.1 回答者： WindFaller 回答日時： 2017/04/19 23:57

エラーが出る原因は、VBAの割当のメモリー(64k)を越えているからなのだと思いますが、もしかしたら、こういうものが一杯あるということでしょうか。

Case "B18"
For Each sp In ActiveSheet.Shapes
If sp.Name = Target.Address Then
sp.Delete
Range("AV18:AY18") = ""
Range("AW18") = "－"
Range("AY18") = "－"
Exit Sub
Next

アイデアを凝らし苦心して作られたとは思いますが、ちょっと無理っぽい内容のようにお見受けします。この場合は、サブルーチンにして、プロシージャを分散させたほうがよいと思います。

For Each sp In ActiveSheet.Shapes
>If sp.Name = Target.Address Then
>sp.Delete

Case "B18"
　Call ShapeDelete1()
Case ...

'-------------------
Sub ShapeDelete1()
'実行するコード

End Sub