EXECEL2000でオートフィルター貼り付けの方法

質問

EXECEL2000のSheet1（Ａ～Ｐ列）にデータが有り、オートフィルターにて
データを抽出後、抽出データをコピーして別シートに溜まっている
データの末尾にペーストするマクロを組みたいのですがどう組んだら良いのか？
教えてください！

回答No.4

vbafriend · ベストアンサー

こんばんは。＃１です。早速マクロを組んでみました。次のように操作してみて下さい。
なお、シート１に抽出するデータが入力されていて同じブックのシート２の最終行のすぐ下にデータを貼り付けるように組んであります。１行目は項目行として考えています。

・データが入力されているブックを開き、ＡＬＴ＋Ｆ１１キーを押してＶＢＥ画面を表示させ、画面右上のVBAProjectと書かれている下のSheet1をダブルクリックして表示された右側の白い部分に書きのコードをコピー＆ペーストする。

Sub Test()

Dim myRow As Long

myRow = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).offset(1,0).Row
Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets(2).Range("A" & myRow)

End Sub

・ＡＬＴ＋Ｆ１１キーを押してエクセルの画面にもどり、メニューバーの上で右クリックして表示されたプルダウンメニューのユーザー設定をクリックする。
・表示されたダイアログボックスのツールバータブをクリックし、右側の新規作成ボタンをクリックして表示されたボックスを何もせずＯＫボタンで閉じる。
・ダイアログ僕巣のコマンドタブをクリックし、分類と書かれている下の白いボックスから新しいメニューを選択する。
・コマンドと書かれている下にも新しいメニュと書かれているのでそこにマウスポインターをあわせ、左ボタンを押したまま表示されているツールバーの上までドラッグしてツールバーの上でボタンを離す。
・選択したボタンの編集と書かれているボタンをクリックして表示されたプルダウンメニューの名前と書かれている右の四角の中にマクロ実行と入れてマクロの登録と書かれている場所をクリックする。
・表示されたダイアログボックスの中の白いボックス(広い方)にThisworkbook.testと書かれている部分にポインターをあわせてクリックするとその上の白いボックスの中に同じものが表示されるので、それを確認後ＯＫボタンでダイアログボックスを閉じ、ユーザー設定ダイアログボックスも×ボタンを押して閉じる。
・表示されているツールバーにマウスポインターをあわせ、浸りボタンを押したままメニュバーのところまでドラッグする。

マクロ実行ボタンをクリックするとマクロが走り出し、貴方様の思い通りの操作を確認できると思います。

オートフィルターは、手で表示させるようにしてあります。

不都合な点・ご不明な点がございましたらお気軽にお知らせ下さい。貴方様の思い通りの動作が実現できるまで、ご一緒に考えていきたいと思います。

お礼

ありがとうございました。お陰様で思い通りの動きになりました。
また宜しくお願いします。

回答No.3

imogasi

（簡単化したテストデータ）Sheet1のA1:C7
県 氏名 住所
東京 大田　一郎 東京都中野区
大阪 小田　次郎 大阪府枚方市
愛知 神田　彬 愛知県小牧市
東京 恩田　和 東京都新宿区
大阪 上田　哲 大阪府大阪市
東京 下田　寛 東京都青梅市
（Criteria）CriteriaとしてA1:C2
県 氏名 住所
大阪
（結果）Sheet3のA-C列
県 氏名 住所
東京 大田　一郎 東京都中野区
東京 恩田　和 　　　　　東京都新宿区
東京 下田　寛 　　　　　東京都青梅市
愛知 神田　彬 　　　　　愛知県小牧市
大阪 小田　次郎 大阪府枚方市
大阪 上田　哲 　　　　　大阪府大阪市
結果はSheet2のA2に
東京－実行、愛知－実行、大阪－実行の結果です。
（コード）
Sub Macro1()
Dim sh1, sh2, sh3 As Worksheet
Set sh1 = Worksheets("sheet1") 'Set sh1 = Sheet1
Set sh2 = Worksheets("sheet2") 'Set sh2 = Sheet2
Set sh3 = Worksheets("sheet3") 'Set sh3 = Sheet3
j = 2
sh1.Activate
sh1.Range("a1:c100").Select
Selection.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
sh2.Range("a1:a2"), CopyToRange:=sh1.Range("a101:c200"), Unique:=False
'--------
d1 = sh1.Range("a101").CurrentRegion.Rows.Count
d3 = sh3.Range("a1").CurrentRegion.Rows.Count
j = d3 + 1
For i = 101 + 1 To 101 + d1 - 1
If Cells(i, 1) <> "" Then
sh3.Cells(j, 1) = sh1.Cells(i, 1)
sh3.Cells(j, 2) = sh1.Cells(i, 2)
sh3.Cells(j, 3) = sh1.Cells(i, 3) 'P列まで羅列追加
j = j + 1
End If
Next i
End Sub
本番に合わせて適当に修正してください。
Ｓｈｅｅｔ１の第1行を、Ｓｈｅｅｔ２の第1行とＳｈｅｅｔ３の第1行に複写してから実行のこと。

お礼

ありがとうございました。
今回は＃1さんの方法でやってみたところお陰様で思い通りの動きになりました。
また宜しくお願いします。

回答No.2

tamagawa49

こんな具合でどうでしょう

Sub 抽出()
Sheets("sheet1").Select
retmsg = MsgBox("オートフィルタで条件を指定してから「貼り付け」ボタンを押して下さい", vbOKCancel + vbInformation, "抽出")
If retmsg = vbOK Then
Range("A1").CurrentRegion.Select
Selection.AutoFilter
Range("A1").Select
Else
End If
End Sub

Sub 貼り付け()
Sheets("sheet1").Select
Range("A1").CurrentRegion.Select
Selection.Offset(1).Select
Selection.Resize(Selection.Rows.Count - 1).Select
Selection.SpecialCells(xlCellTypeVisible).Copy

Sheets("sheet2").Select
Dim r As Long
r = ActiveSheet.Rows.Count

Cells(r, 1).End(xlUp).Offset(1).Select
ActiveSheet.PasteSpecial
Range("A1").Select

Sheets("sheet1").Select
Application.CutCopyMode = False
Selection.AutoFilter
Range("A1").Select

Sheets("sheet2").Select
End Sub

シート１でマクロ「抽出」を実行。オートフィルタで条件を設定したら、次にマクロ「貼り付け」でシート２の最下行の続きに貼り付け。

ただし、Ａ～Ｐ列には全て空の列はないと仮定して作りました。
では、頑張って下さいね。

お礼

ありがとうございました。
今回は＃1さんの方法でやってみたところうまく出来ました。
また宜しくお願いします。

回答No.1

vbafriend

初めまして。私でよろしければサンプルマクロを組んでみたいと思います。
これだけでは、マクロを組むことが出来ません。もしご希望の節は、私が手元で貴方様と同じ操作をすることが出来るように、具体的に詳しく操作方法を教えて下さい。コードをコピー＆ペーストするだけで貴方様の思い通りの動作をするサンプルマクロを組めるかと思います。

お手数をおかけいたしますが、よろしくお願いいたします。

補足

早速のお返事ありがとうございます。
補足ですが"Sheet1"のＡ～Ｐ列"にあるデーターにオートフィルタを
掛けるのは条件が色々かわるのでハンドでやります。
コピーというボタンを設けてクリックすると
フィルタで出てきた結果のデータを"保存用シート"に溜まっているデータ
（"Sheet1"同様の配列）に追加していきたいのですが・・・
つたない説明ですみません。