エクセルで型番ごとにワークシートをマクロで作る方法

昨日質問させて頂いたものです。
説明が下手でなんとかうまく伝えられる文章を考えてみました。

やりたいことは、画像のワークシート「メイン」をから[移動またはコピー]
で新たにワークシートを作成し、新しいワークシートから
2001の型番よりしたの型番を削除し2001だけのワークシートをつくり、
次に2002の型番より上の2001と2002より下の型番を削除し、
2002だけのワークシートを作りたいです。
つまりは、単体の型番だけのワークシートを作りたいです。
ちなみに１，２，３行は消したくないです。
この一連の作業をマクロで作れる方お願いします。。

No.1 ベストアンサー 回答者： keithin 回答日時： 2011/10/19 13:09

こんなカンジで。

元のシートを開いて実行します。

Sub macro4()
　Dim h As Range
　Dim w As Worksheet
　Dim i As Long, e As Long
　Application.ScreenUpdating = False
　Application.CutCopyMode = False

’準備
　Set w = ActiveSheet
　w.Range("4:4").Insert shift:=xlShiftDown
　e = Range("B65536").End(xlUp).Offset(1).Row
　Range("B4").Select

’複写
　Do
　　ActiveSheet.Copy after:=ActiveSheet
　　Selection.EntireRow.Delete shift:=xlShiftUp
　Loop Until ActiveCell.Offset(1) = ""

’片付け
　For i = ActiveSheet.Index To w.Index + 1 Step -1
　With Worksheets(i)
　.Range(.Range("B4").Offset(1), .Cells(e, "B")).EntireRow.Delete shift:=xlShiftUp
　End With
　Next i
　w.Rows(4).Delete
　Application.ScreenUpdating = True
End Sub

この回答への補足

まさにこういう作業です。

もうひとつ疑問に思ったのですが、自分が作ったデータで217行からの型番のワークシートが生成されないのですが
どうすればよいでしょうか？

補足日時：2011/10/19 16:17