エクセルで抽出したデータを別シートにコピーしたいです

質問

エクセル2003を使用しています。
例えば、以下のような表があります。

　ＡＢＣ
１あ10
２い15
３あ20
４

A列が条件となり、たとえば「あ」のデータだけ抽出して、そのデータを別シートにコピーします。
同じく「い」だけを抽出して、また別のシートにコピーします。
いままでは、オートフィルタで抽出して自分でコピーをして貼り付けしていましたが、日々データが次の行に追加になるので、毎回オートフィルタしてコピーするのは大変です。
関数か、マクロかVBAを使ってする方法はありますでしょうか。
できれば日々追加になるデータのみをすでにある別シートの前日までのデータの下に追加できるようになればいいと思うのですが。
知識が乏しくできません・・・
よろしくお願いいたします。

回答No.4

dokinhime · ベストアンサー

抽出したい条件は全てＧ列に縦に列挙してください。そして、その条件で抽出したデータをコピーしておくワークシート名をＨ列に入力します。
（Ｅ２のセルにはＧ列で列挙した抽出条件が順次入力されるセルです。）抽出結果のデータはＨ列で指定したワークシートにそれぞれあるはずです。

お礼

お返事遅くなってすみません。
うまくできました。
ありがとうございました！！

回答No.3

dokinhime

No.1について
コピーしたものは標準モジュールに貼り付けて下さい。
（「挿入」メニューの「標準モジュール」で標準モジュールができます。）
エラーメッセージが400のみであれば、それで解決すると思うのですが、400のほかにメッセージがある場合は他の解決法となります。

補足

ありがとうございます。標準モジュールに貼り付けてみました。エラーは出なくなりましたが、E2の条件を入れた値がマクロを実行するといつも「い」に変わってしまいます。
抽出も「あ」が抽出できなくなっています。
すみません・・・なぜなんでしょう。

回答No.2

imogasi

関数では複雑になって手におえないでしょう。関数は抜き出しが苦手です。
VBAによる解決になるでしょう。
今までのやり方からして、バッチ方式＝瞬時連動でなく、人間が指示したときに実行、でよいのですね。
Sheet1に
あ10
い15
あ20
のデータがあるとする。
＞日々データが次の行に追加になるので
はSheet1に対してでしょね。
＞「あ」のデータだけ抽出して、そのデータを別シートにコピーします。
「あ」の行をコピーする「シート名」はどういう風になってますか。
規則性がありますか。A列文字列そのものがシート名だったりしますか。
結局
Sheet1のA列に出てくる文字列によって
あー＞Sheet2
いー＞Sheet3
うー＞Sheet4
・・
のようにシートに振り分けるか。
ソートして
「あ」の塊り行ーー＞Sheet2
「い」の塊り行ーー＞Sheet3
・・
にコピーすればよい。
あーいーう・・・の並びと
Sheet2－Sheet3－Sheet4・・の並びと一致しているとさらにやりやすい。
Sheet2以下は毎日新規作り直しの方がやりやすそう。

補足

ご回答ありがとうございます。
理屈はわかりましたが、実際にどのようにvbaを書けばいいのかが、わからず・・・
すみません。

回答No.1

dokinhime

AdvancedFilterを使ってはどうでしょうか。
追加になったデータだけを抽出というのは
結構面倒な作業なので、毎回全データをフィルターして
貼り付ける方法を記述してみました。

1行目にフィールド名（仮にXYZとしました。）を入れています。
そして、抽出したいＡ列のフィールド名ＸをＥ１に記入して
その下に抽出したい「あ」を仮に入れています。

またＧ列に抽出したいＸフィールドの文字を縦に列挙しておきます。
その横のＨ列には、「あ」で抽出したデータを「Sheet2」ワークシートにコピーするというように、対応するコピー先ワークシートの名前を記述します。

　Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ
1 Ｘ Ｙ Ｚ 　 Ｘ 　 Ｘ シート名
2 あ １ ０ 　 あ 　 あ Sheet2
3 い １ ５ 　 　 　 い Sheet3
4 あ ２ ０

Sub FilterDataCopy()

　Dim MyRow As Long 'G列の行を入れる変数

　Application.ScreenUpdating = False
　MyRow = 2

　'まず前日の抽出データを全てクリア
　Do Until Sheets("Sheet1").Cells(MyRow, "g") = ""
Sheets(Sheets("Sheet1").Cells(MyRow, "h").Text).Select
Cells.Select
Selection.ClearContents
MyRow = MyRow + 1
　Loop

　Sheets("Sheet1").Activate
　MyRow = 2
　'抽出してコピー
　Do Until Cells(MyRow, "g") = ""
Range("e2") = Cells(MyRow, "g")
Range("a1").CurrentRegion.AdvancedFilter xlFilterCopy, Range("e1:e2"), Sheets(Cells(MyRow, "h").Text).Range("a1")
MyRow = MyRow + 1
　Loop

　Application.ScreenUpdating = True

End Sub

補足

ご回答ありがとうございます。
早速、やってみましたが、エラーが出てどうしてもうまく行きません。
基本的なことがわかっていないのでどこが悪いのかがわからないのです。
ちなみに、エラーメッセージは「４００」となっています。