エクセルマクロの分割方法について

質問

Sub リスト登録()
'
' Macro3 Macro
' マクロ記録日 : 2008/6/2

'
ActiveSheet.Unprotect Password:="1234"
If Range("G33").Value > 5 Then
Sheets("リスト").Select
ActiveSheet.Shapes("AutoShape 44").Select
Selection.Copy
Sheets("シート").Select
Range("A15").Select
ActiveSheet.Paste
End If
Dim Btn As Integer
Dim strMsg As String
strMsg = "リストに登録しますか？"
Btn = MsgBox(strMsg, vbYesNo + vbQuestion, "MsgBox")
If Btn = vbNo Then
Dim YU As Shape
For Each YU In ActiveSheet.Shapes
If YU.Type = msoAutoShape Then
YU.Delete
End If
Next
If Btn = vbYes Then
End If
ActiveSheet.Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("C11").Select
End
End If
Dim newRange1 As Range, newRange2 As Range, newRange3 As Range
Select Case Sheets("").Range("B3").Value
Case 1
Set newRange1 = Sheets("リスト").Range("I6")
Set newRange2 = Sheets("リスト").Range("AH6")
Set newRange3 = Sheets("リスト").Range("AI6")
中略
Case 1000
Set newRange1 = Sheets("リスト").Range("I1005")
Set newRange2 = Sheets("リスト").Range("AH1005")
Set newRange3 = Sheets("リスト").Range("AI1005")
ActiveWorkbook.Save

Case Else
End Select

Application.ScreenUpdating = False
Sheets("シート").Range("G8,G10,G12:G23,G25:G29,G31:G32").Copy
newRange1.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
newRange1.UnMerge
Sheets("シート").Range("D34").Copy
newRange2.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("シート").Range("I29").Copy
newRange3.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("シート").Select
Range("C11").Select
Range("D34,G8:G32,I29").Select
Selection.ClearContents
Range("C11").Select
Dim SP As Shape
For Each SP In ActiveSheet.Shapes
If SP.Type = msoAutoShape Then
SP.Delete
Range("D34:K34").Select
Application.CutCopyMode = False
Selection.Merge
Range("B3").Select
End If
Next
ActiveSheet.Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
上記のマクロを作成しましたが、６４Ｋを超えてしまう為、分割したいのですが、どのように分割すればよいのか方法がわかりません、どなたかお分かりの方がいらっしゃいましたら宜しくお願いします。
マクロシート１～２～３といったつなぎの構文がわかりません宜しくお願い致します。

回答No.1

n-jun · ベストアンサー

＞Select Case Sheets("").Range("B3").Value
＞Case 1
＞Set newRange1 = Sheets("リスト").Range("I6")
＞Set newRange2 = Sheets("リスト").Range("AH6")
＞Set newRange3 = Sheets("リスト").Range("AI6")
＞中略
＞Case 1000
＞Set newRange1 = Sheets("リスト").Range("I1005")
＞Set newRange2 = Sheets("リスト").Range("AH1005")
＞Set newRange3 = Sheets("リスト").Range("AI1005")
＞ActiveWorkbook.Save
＞Case Else
＞End Select
って

Dim i_row As Long

i_row = Sheets("").Range("B3").Value 'シート名？？？

Set newRange1 = Sheets("リスト").Range("I" & 5 + i_row)
Set newRange2 = Sheets("リスト").Range("AH" & 5 + i_row)
Set newRange3 = Sheets("リスト").Range("AI" & 5 + i_row)
でもいいのでは？
ただ行数の制限（１００５行までとか）があるならば、その判定は必要ですけど。

あとは、
Selectするな！
http://www.officetanaka.net/excel/vba/speed/s2.htm
にもありますが、Selectを減らすとか？

お礼

n-junさん
早速の回答大変有難う御座いました。
マクロって難しいですね、こんなにも簡素化出来るなんて思ってもいませんでした、今まで１０００を越える入力が嘘のようです、こんなに短く出来るには相当の知識が必要ですよね、私には到底出来ませんが、本当に有難う御座います。
他にも長い物がありますので頑張って短く出来る様に挑戦してみます。
本当に感謝致します。