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

昨日に質問させて頂いたものですが、下記のマクロを教えて頂いたのですが
新しく生成された型番のワークシートが抜けていたり、最後まで型番が生成されない状態です。
なにか間違っていたら直して頂ける方お願いします。

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





http://oshiete.goo.ne.jp/qa/7081084.html

No.1 ベストアンサー 回答者： keithin 回答日時： 2011/10/20 12:35

あなたが用意したリストが，ご相談で掲示されているように作成できていないのが直接の原因です。

●同じ型番の製品が２行以上あるときに，型番のセルがセル結合できていない
●リストの途中に空白行が紛れている（少なくとも型番列の記入が抜けている）
などの状況が，真っ先に疑われます。データをキチンと直してから実行してください。



若しくは，実際のデータはご質問で掲示されたようには作成できないというのでしたら，マクロを例えば次のように直します。
変更前：
Loop Until ActiveCell.Offset(1) = ""

変更後：
loop until application.counta(activecell.offset(1).resize(e, 1)) = 0

ただしこういった「泥縄式」の対応は，また何か間違ったリストの作り方をされるたびにイチイチマクロを手直して行かなきゃならなくなる（いったいどんなデタラメが紛れてくるのか，事前に全てを予測して備えるのは無駄な作業です）ので，データ整備のほうをキチンと行うようにしてください。



＃ご相談の出し直しは勿論全く問題ありません（他の方からもまた違ったアプローチ等が提案されるチャンスにもなります）が，その際は以前のご相談投稿は「解決」で閉じて，放置しないようにしてください。

この回答への補足

やはり型番が一部ぬけてワークシートが作成されてしまいます。
サンプルを作ったので、もしよろしければマクロをいれて稼動させてみてください。

http://www.dotup.org/uploda/www.dotup.org2160874 …

補足日時：2011/10/20 15:41