振分け処理の問題点、教えてください

質問

見よう見まねで、下記コードを何とか作ってエラーせず処理できましたが、
もう一ひねり？　いや二ひねりができません　（TT）
商品シートを変数にして、ループ？で同ブック内の商品シートに振り分けたいのです

■下記コード結果の問題点
・商品シートをループ処理できません（どこにFor分？Loop分？置き方、何かゴチャゴチャになって・・・）
・抽出はOKですが、商品シートの項目も一緒にA5から貼り付けられてしまう
・AutoFilterでシート1からコピーの際、商品シート名除いてコピーできないか？（B5からデータだけほしい）
・各商品シートにはデータを残しておきたいので、貼り付けの際、最終行に追加していく

■シート１　注文データ　（1行目に項目、2行目からデータ）週一回更新
A列　商品シート名　/B列　注文NO　/C列　商品名　/D列　個数　/E列　備考
↓
ランダムに100件ほど

■商品シート　同ブック内に商品種類分を作成済み　（4行目に項目、5行目からデータ）
A列　空き　　　　　/B列　注文NO　/C列　商品名　/D列　個数　/E列　備考

3日間悩んでいます、どなたか助けてください

-----------------------------------

'受注シートから各商品シートへの振分け
Private Sub CommandButton1_Click()

'注文シートからデータ抽出
Worksheets("シート1").Activate
Range("A1").AutoFilter Field:=1, Criteria1:="商品シート"
Worksheets("sheet1").AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy

'商品有効チェック
Set dumu = Range("A2").CurrentRegion
umu = dumu.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If umu = 0 Then
MsgBox "商品がありません"
GoTo syuryo
Else

'シート名と商品コード一致チェック貼り付け
For Each Wh In Worksheets
If Wh.Name Like "商品シート" Then
Worksheets("商品シート").Activate
With ActiveSheet
.Range("A5").PasteSpecial xlPasteValues
.Range("A1").Select
End With

End If
Next
End If

syuryo:
Worksheets("シート1").Activate
Worksheets("シート1").AutoFilterMode = False
Application.CutCopyMode = False
Range("A1").Select
End Sub

回答No.1

keithin · ベストアンサー

つまり整理すると…
１．マクロ実行前の事前の準備として。
　　商品名シートは，マクロを実行の前に「事前に手動で」作成済みである
　　商品名シートの４行目は，「事前に手動で」項目行を記入済みである

２．マクロの実行によって。
　　シート１（注文データ）から商品名シートに，シート名に合致するデータを転記したい
　　データを転記したら，転記したデータはシート１から抹消したい

sub macro1()
　dim w as worksheet
’全てのシートを巡回する
　for each w in worksheets
　if w.name <> "シート１" then
’各商品名のシートについて
　　if application.countif(worksheets("シート１").range("A:A"), w.name) > 0 then
　’そのシート名に合致するデータがあったので，絞ってコピーして抹消する
　　worksheets("シート１").range("A:E").autofilter field:=1, criteria1:=w.name
　　worksheets("シート１").autofilter.range.offset(1, 1).copy _
　　　destination:=w.range("B65536").end(xlup).offset(1)
　　worksheets("シート１").autofilter.range.offset(1).entirerow.delete shift:=xlshiftup
　　end if
　end if
　next
　worksheets("シート１").autofiltermode = false
end sub

お礼

何とか解決できました
どうしても余分に貼り付けてしまうので、F列をダミー列として
既存の計算式が消えないようにしました。
　これで正解かはわかりませんが・・(^^ゞ

本当にありがとうございました！

補足

ありがとうございます！
何かこんなにコンパクトにできるんだなと、あっけにとられてます
自分、まだまだです。助かります。
マスタデータは問題なく各商品シート指定セルに振分けられました。
が、

■商品シート　同ブック内に商品種類分を作成済み　（4行目に項目、5行目からデータ）
A列　空き　/B列　注文NO　/C列　商品名　/D列　個数　/E列　備考

例えば、転記データが２レコードとします
商品シート
4行目は項目
5行目　注文NO・・・・・・・　　　/E列　備考　/F列（数式と罫線が消えてしまいます）
6行目　注文NO・・・・・・・　　　/E列　備考　/F列（数式と罫線が消えてしまいます）
7行目　（この行の罫線が消えてしまいます）　 /F列（数式と罫線が消えてしまいます）
8行目　（ここから下の罫線は大丈夫です）　　 /F列（ここから下は大丈夫です）

転記データ(B-E)は問題ありません
それを囲むように、元の商品シートにあったすぐ下と
横のセルF列の内容（罫線や計算式）が消えてしまいます
フィルターの指定とか？何か設定があるのでしょうか？
いろいろ試したのですが、いい結果が得られません。