ＶＢＡが動かない。

質問

初心者ですが、必要にせままれてVBAを習得努力中ですが、参考書からＣ＆Ｐして何とか動き？始めたが、途中実行時エラー：１００４に引っかかって作動しなくなり使用を止めていました。現在１－２－３のロータスのマクロでなんとかしのいでいますが、やはりエクセルを使用しないと物事はスムーズに進みません。これはデータ入力後の作業の出だしのマクロです。どなたかご教授いただけませんか？
ＱＴ
Sub シート挿入()
'初回の追加()
Worksheets.Add After:=Worksheets("データ_変換")
ActiveSheet.Name = "1"
'シート修正の追加()
Worksheets.Add After:=Worksheets("1")
ActiveSheet.Name = "2"
End Sub

Sub 初回、修正のデータ抽出()
Dim xRange As Range, yRange As Range
Dim sName, allName
Set xRange = Worksheets("データ_変換").Range("A4").CurrentRegion
allName = Array("1", "2")
For Each sName In allName
Range("D2").Value = sName
Set yRange = Worksheets("データ_変換").Range("A1").CurrentRegion
xRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=yRange, _
CopyToRange:=Worksheets(sName).Range("A1")
Next
Set xRange = Nothing: Set yRange = Nothing
End Sub
UNＱＴ
以上ですが、シート１，２を追加した後それぞれのシートに抽出条件回数（Ｄ列）である１，２毎にフルデータを抽出するもので、フィールド名は４行目Ａ列からＢＩ列で約２０００件のデータです。
当初はなにもしないでマクロ実行時にそれぞれのシートにフルレングスのフィールド行とデータがＡ１からＢＩ１のフィールド名とともに書き出されました。また自動的に「データ_変換」のフィールド行が同シートの上のＡ１にコピーされＤ列の下の２行目に２の数字が書き込まれて作業は無事完了していました。
以上よろしくお願いします。

回答No.4

myRange

回答２、myRangeです。

抽出マクロにも問題はあったのですが、
抽出マクロで、エラー１００４が出るのは特別な場合、
手動で抽出結果のシート１，２のField名を消したり
別なfield名に変更した場合ですから
まさかそんなことはしないだろうと思い
挿入マクロの方で回答したしいだいです。

抽出マクロの問題は、
マクロを実行するとき、どのシートがアクティブになってるかです。
"データ_変換"シートがアクティブな状態で実行すると
そのままのコードで上手くいきますが、
他のシートがアクティブな状態で実行すると、エラーが出たり、意図しない結果が出たりします。

他の補足にあるような結果が出たのはまさにそうです。

で、"データ_変換"シートがアクティブでなくても上手くいくようにするには、
以下の▲のRangeの前に
●のようにシートオブジェクト、Sheets("データ_変換")を付加してやればOKです。

▲Range("D2").Value = sName

を

●Sheets("データ_変換")Range("D2").Value = sName

とする。

それから、シート１，２の１行目に手動で、Fieldをコピペする必要はありません。

また、回答３で指摘されてるWorksheets(sName).Cells.ClearContentsは、今回のエラーとは関係なく必要になります。
１回目、２回目、３回目と抽出件数が少なくなると前のが残ったままになるので。

以上です。

お礼

ありがとうございます。
試して見ましたが、だめです。
今回は
実行時エラー：２１４７６２５９
　　AdvanceFilterメッソッド失敗しました　Rangeオブジェクト。。。
尚、以上は貴アドバイスまえに実行したときも同じエラーです。
ますます深みにはまる様です。
１，２のシートは削除し、挿入する以外は一切手を着けていません。
またアクティブの件は、マクロ実行時必ず本体シートのA５（データの頭）にクリックをしてから行っています。
業務の出だしのマクロなので何とかブレイクスルーできればと思っています。
以上ご報告まで。

回答No.3

nag0720

試してみました。
確かに１回目は正常にコピーされます。
そのまま２回目のマクロを実行しても正常終了しますが、「データ_変換」のデータを変えてマクロを実行すると、「１００４」のエラーがでました。
しかし、シート１，２のセルをクリアしてから実行すると大丈夫でした。

AdvancedFilterはコピー先のセルに対象外のデータが入っているとうまくいかないようです。
対応策として、
For Each sName In allName
の後に、
Worksheets(sName).Cells.ClearContents
を入れてみてはどうでしょうか。

お礼

補足説明いたします。
再度チェックしました。データ件数は一件マイナスではなく同数です。全く同じものが１，２にコピーされ、１，２のデータ毎の抽出は行われていません。
以上ご報告いたします。

補足

ありがとうございます。
初心者で申し訳ありません。
試して見ました。
先ずもとデータのＡ１行欄にフィールド名をコピーしました。
次にご指摘の行を追加して実行したら、シート１は回数（Ｄ列）に下（２行目）に２が、一方シート２には１が表示されました。データは全く同じで１のデータが一件その他は２のデータです。但し元データ件数より一件少ない。
当初は全くうまく行き件数が約半々に分かれて表示されてご機嫌でしたが？
以上ご報告まで。

回答No.2

myRange

＞途中実行時エラー：１００４に引っかかって作動しなくなり

「シート挿入」マクロを２回（複数回）実行したのではありませんか？
１回目の実行で、シート"１"，"２"が出来きますよね。
そこで更に「シート挿入」マクロを実行すると、
「シート"１"は既にありますよ」とのエラーになるわけです。

「シート挿入」の実行を１回だけしか許さないということであれば
下記のように●と●の間の３行を追加してください。
これで「シート挿入」を何回実行してもエラーは出なくなります。

'----------------------------------------
Sub シート挿入()
'●
　　On Error Resume Next
　　Worksheets("1").Select
　　If Err.Number = 0 Then Exit Sub
'●
Worksheets.Add After:=Worksheets("データ_変換")
ActiveSheet.Name = "1"
Worksheets.Add After:=Worksheets("1")
ActiveSheet.Name = "2"
End Sub
'---------------------------------------

何れにしろ、
「シート挿入」マクロを複数回実行する必要があるのか
あるとすれば、シート名はどうするのか、
等々、も少し詳しく補足する必要があるでしょう。
以上です。

補足

ありがとうございます。
確かに説明不足でした。
シートの追加マクロは作業実行後適宜１，２を削除した場合に新たにやり直すときに使用しています。

回答No.1

redfox63

抽出先のシート1,2にフィールド名が無いのが原因かもしれませんよ

Sub シート挿入()
　　dim r as Range, sh as WorkSheet
　　' フィールド名のセル範囲の取得
　　Set r = Worksheets("データ_変換").Range("A1").CurrentRagion.Resize(1)
　　set sh = ActiveSheet
　　'初回の追加()
　　Worksheets.Add After:=Worksheets("データ_変換")
　　ActiveSheet.Name = "1"
　　' 追加シートへの転記
　　r.Copy ActiveSheet.Range("A1")
　　'シート修正の追加()
　　Worksheets.Add After:=Worksheets("1")
　　ActiveSheet.Name = "2"
　　' 追加シートへの転記
　　r.Copy ActiveSheet.Range("A1")
　　' 最初に選択されていたシートを選択
　　Sh.Select
End Sub

補足

ありがとうございます。
現在のところ「Worksheets(sName).Cells.ClearContents」を追加して問題なく作動するのですが、抽出結果は１，２毎に抽出されるのではなく全く同じ物がそれぞれにコピーされています。
以上ご報告致します。