金額欄の計算結果が500以上となる行のデータを抜出して他のシートにコピーするマクロ

質問

Sheet1 のA5セルから始まって、 月日、項目、数量、単価、金額(円)、備考 　からなる表があります（上4行は空欄）。
E6の金額欄は「 ＝数量＊単価 ( =C6*D6 ）」の数式で示され、列方向に数十行ソートされて各行の金額が計算されています。他の欄のデータは手入力で埋められています。

この表の中から、金額欄が500円以上となる行だけを全て抜出して、Sheet2 のA3セルを起点に表示させるマクロを作りたいと思っています。
なお、データの行数は日にちとともに増えてゆきます。

「新しいマクロの記録」を使って工夫しようと思いましたが、【１】オートフィルタでは、他のSheetへの抽出が難しいようです。
また、【２】フィルタオプションの設定では、(1)検索条件範囲はSheet2を選択した状態で指定するものでしょうか？
(2)金額欄が1000円以上であることの条件は、具体的にどのように指定すれば良いのか要領が分かりません。
(3)実際にフィルタリングさせてみると、見出し行だけがSheet2にコピーされ、肝心のデータ領域は選ばれないので困っています。

新しいマクロの記録を使わない、よりすっきりした方法を教えていただければその方ありがたいです。
フィルタオプションの使い方についても今後の参考として教えていただけるとたいへんありがたいのですが。よろしくお願いします。

回答No.5

imogasi · ベストアンサー

＞フィルタオプションの使い方についても今後の・・
結構時間がかかりました。
一旦同シート内に抽出しSheet2にコピーしてます。
例データ　　Sheet1のA4:E13＋G4:G5
A列　　B列　　　C列　　　D列　　　E列　　　　　G列
月日 項目 数量 単価 金額 金額
2006/3/1 12 23 20 460 >1000
2006/3/2 12 23 20 460
2006/3/3 12 23 20 460
2006/3/4 12 54 20 1080
2006/3/5 12 23 20 460
2006/3/6 12 54 20 1080
2006/3/7 12 23 20 460
2006/3/8 12 23 20 460
2006/3/9 12 65 20 1300
Sub Macro1()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("A65536").End(xlUp).Row
sh1.Activate
sh1.Range(sh1.Cells(4, "A"), sh1.Cells(d, "E")).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=sh1.Range("G4:G5"), _
CopyToRange:=sh1.Cells(4, "I")
'CopyToRange:=sh2.Range(sh2.Cells(4, "I"), sh2.Cells(d, "M")), Unique:=False
sh1.Range("I4").CurrentRegion.Select
Selection.Copy Destination:=sh2.Cells(5, 2)
sh1.Range("I4").CurrentRegion.Select
Selection.Clear
End Sub
実行結果
Sheet2の　B5:F8
月日 項目 数量 単価 金額
2006/3/4 12 54 20 1080
2006/3/6 12 54 20 1080
2006/3/9 12 65 20 1300
もし１０００以上を実行の都度指定するなら
Sub Macro1()
n = InputBox("いくら以上")
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
sh1.Cells(5, "G") = ">" & n
d = sh1.Range("A65536").End(xlUp).Row
以下同じ（略）
でどうですか。

お礼

補足の内容は間違ってました。
問題なく抜き出しコピーできました。

申し訳ございませんでした。

補足

実行結果は月日、項目・・・　の1行だけしか表示されません・・・。1000以上の3行のデータは何も表示されません。
少し考えてみましたが、初心者には実行結果が異なる理由は分かりませんでした。

でも、VBAでフィルタオプションの検索条件範囲を指定する方法など参考になります。また、InputBoxはうまくいきそうです。(最初の問題が解決できれば・・・）

お聞きしたいのですが、マクロの達人になると今回のレベルのマクロなどは、まったく白紙の状態からでもソフトとしては、スラスラと作れるものなのでしょうか？少しくらいは時間がかかっても。
それともやはり本や他のソフトなどを参考にして作るのが普通なのでしょうか？

ついでに、今回のマクロ中の’がついている行は、何かをチェックするためのものですか？

回答No.7

noname#204879

[No.6回答に対する補足]に対する回答、

[アクティブセル領域の選択]の実行とは、次のステップのことです。
１．[編集]→[ジャンプ]→[セル選択]を実行
２．“アクティブセル領域”に目玉入れ
３．[OK]をクリック

以下は“付録”です。
私は上の操作を一発で実行してくれるアイコンを[ツールバー]に登録しています。その方法は…
ａ．[ツール]→[ユーザー設定]→[コマンド]を実行
ｂ．左窓で“編集”を選択
ｃ．右窓をスクロール・ダウンして現れる“アクティブセル領域
　　の選択”をマウスでドラッグして、[ツールバー]上のお好み
　　場所にドロップ
ｄ．そのドロップした“テキスト”表示アイコンをマウスで右ク
　　リックして“既定のスタイル”を選択
ｅ．[OK]をクリック

補足

操作方法は分かりました。ありがとうございます。

４と５を省略して、フィルタリングされた結果の範囲をドラッグして、コピー／貼り付けても結果は同じですよね。

４はフィルタリング結果の範囲の大きさがどんなに違っても、どんなに大きな範囲になっても、同じ方法でコピー範囲が選択できるというメリット、さらにアイコンをツールバーに登録しておけば、クリック１つで目的の領域が選択できるという大きなメリットがありそうだと思われます。

しかし５を操作する目的は何なのかよく分かりません。何度も申し訳ありませんが・・・。

回答No.6

noname#204879

[No.1回答に対するお礼]に応えて、

マクロで解決できて良かったですね。ではリクエストに応えて“クラシック”な手動による方法を述べておきます。

【１】[オートフィルタ]による法
------------------------------
１．Sheet1 のデータ範囲内の任意の単一セルをアクティブにして
　　[オートフィルタ]を実行
２．セル E5 の[オートフィルタ]矢印(▼)をクリックして“(オプ
　　ション)”を選択
３．上段左のボックス内に 500 を入力して、その右ボックス内で
　　“以上”を選択して[OK]をクリック
４．抽出されたデータ内の任意の単一セルをアクティブにして[ア
　　クティブセル領域の選択]を実行
５．念のために[可視セルの選択]を実行
６．[コピー]を実行
７．Sheet2 のセル A3 をアクティブにして[貼り付け]を実行

【２】[フィルタオプションの設定]による法
----------------------------------------
(Sheet1 では[オートフィルタ]の設定を解除しておくこと)
10．Sheet1 の範囲 A5:F5 を[コピー]して、それを Sheet3 のセ
　　ル A3 に[貼り付け]
11．Sheet1 のセル E5 を[コピー]して、それを Sheet3 のセル H1
　　に[貼り付け]
12．Sheet3 のセル H2 に >=500 と入力
13．Sheet3 に任意の空白セルをアクティブにして、[フィルタオ
　　プションの設定]を実行
14．“指定した範囲”に目玉入れ
15．[リスト範囲]ボックス内にマウスカーソルを置く
16．Sheet1 に移動した後、元データの全範囲(A5:Fn)をドラッグ
　　指定
17．[検索条件範囲]ボックス内にマウスカーソルを置く
18．Sheet3 の範囲 H1:H2 をドラッグ指定
19．[週出範囲]ボックス内にマウスカーソルを置く
20．Sheet3 の範囲 A3:F3 をドラッグ指定
21．[OK]をクリック

試してみて上手く行かなかったら、ステップ番号を特定して質問願います。

補足

どんな参考書、インターネットの解説ページより、グンと明快です。分かりやすいです。途中に空白行があっても問題ありませんね。

ひとつだけ、４．「アクティブセル領域の選択」方法が分かりません。補足回答いただければ幸いです。

回答No.4

imogasi

#3です。
Sub test01()
'Sheet1とSheet2の定義
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
'Sheet2の最初行を
j = 3
'最下行を知る
d = Sh1.Range("A65536").End(xlUp).Row
'本件ではスタート行は第五行
For i = 5 To d
'各行処理）
'各行処理での判別
If Sh1.Cells(i, "E") > 1000 Then
'該当処理
For k = 1 To 5
Sh2.Cells(j, k) = Sh1.Cells(i, k)
Next k
j = j + 1
'列数だけ繰り返す。
End If
Next i
'各行の処理を繰り返す。
End Sub

お礼

うまく行きました。問題解決です。
朝のおいそがしいときに、No.3をいただき、また夜になってNo.4を教えていただいて、たいへんありがたく思っています。

エクセルやVBAを使いこなせるのはすごいなと、あらためて感じました。私も引き続き勉強します。

回答No.3

imogasi

Sheet1とSheet2の定義
Set Sh1=Worksheets("Sheet1")
Set Sh2=Worksheets("Sheet2")
Sheet2の最初行をｊ＝3
（１）最下行を知る
d=Sh1.Range("A65536").End(xlUp).Row
（２）本件ではスタート行は第五行
（３）For i=5 to d
(各行処理）
next i
で各行の処理を繰り返す。
（４）各行処理での判別
IF文で
If Sh1.Cells(i,"E") > 1000 Then
(該当処理）
End If
（５）該当処理は
For k=1 to 5
Sh2.cells（ｊ,k)=Sh1.cells(i,"A")
Next k
で列数だけ繰り返す。
以上を参考に。
時間がないので全体は省略、機会あれば夜に入れます。

回答No.2

merlionXX

Ｅ列の数値が500以上のものをSheet2に抽出するマクロです。
ただし、Ｅ列にはデータの途中に空白行がないものとします。

Sub test01()
n = 2
With Sheets("Sheet1")
For i = 5 To .Range("E5").End(xlDown).Row
If .Cells(i, "E") >= 500 Then
n = n + 1
Sheets("Sheet2").Rows(n).Value = .Rows(i).Value
End If
Next
End With
End Sub

お礼

空白行がないという条件で、うまく行きました。

実際は、数量未定で空白行のある場合があります。
その場合は、マクロの動作は空白行の前までで止まってしまうことも分かりました。

No.4imogasiさんの方では、この問題も解決できました。でも深夜、質問の時間からすぐにご回答いただいておどろいています。何日も苦心しているところをあっという間に解決していただきました。
ありがとうございました。

回答No.1

noname#204879

私はマクロ不能者なので、ご質問に対する回答はできないのですが、気になったもので…

【１】も【２】も手動では難なくできますが、手動で実現可能な操作でもマクロで不可能なことがあるのですか？もし、手動でできないと誤解されているのなら、その旨お知らせください。ご希望なら、操作をご案内いたします。

お礼

上のNo2merlionXXさんと　No4imogasiさんに教えていただいた方法で、マクロの実行は確認できました。
でも、手動ではうまく行きません。

今後もオートフィルタやフィルタオプションの設定を使うことがあると思いますので、手動での設定方法をご教授いただければたいへんありがたく存じます。

よろしくお願いします。