文字を検索してその行を別シートにコピーするマクロ

質問

A列　郵便番号　B列　住所　C列 名前

で出来ているファイルがあるのですが、住所欄にある市ごとにその行を別のシートにコピーさせたいと考えています。

マクロを起動させ、ダイアログボックスにコピーしたい市を入力するとSheet2又は新しいシートにコピーするマクロが出来たら助かるのですが、私用の範囲内で使いますのでご教授お願いします。

回答No.1

keithin · ベストアンサー

sub macro1()
　dim res as string
　dim w as worksheet
　set w = activesheet
　res = inputbox("市")
　if res = "" then exit sub

　application.screenupdating = false
　range("B:B").autofilter field:=1, criteria1:="*" & res & "*"
　worksheets.add
　w.range("A1").currentregion.copy destination:=range("A1")
　w.autofiltermode = false
　application.screenupdating = true
end sub
などのように。

お礼

こんな単文でできるのですね驚きました。
ありがとうございます。

回答No.2

tom04

こんばんは！
一例です。

Sheet１のデータをSheet２に表示するようにしてみました。

項目は何列あっても大丈夫ですが、↓の画像のように検索列（住所欄）はB列とします。

Alt＋F11キー　→　VBE画面が出ますので、↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j, k As Long
Dim ws1, ws2 As Worksheet
Dim str As String
Set ws1 = Worksheets("sheet1") '←Sheet名は適宜変更
Set ws2 = Worksheets("sheet2") 'こちらのSheet名も・・・
str = InputBox("検索したい市を入力してください。")
If WorksheetFunction.CountIf(ws1.Columns(2), "*" & str & "*") Then
ws2.Cells.Clear
i = ws1.Cells(Rows.Count, 1).End(xlUp).Row
j = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Range(ws1.Cells(1, 1), ws1.Cells(i, j)).AutoFilter _
field:=2, Criteria1:="*" & str & "*"
k = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Range(ws1.Cells(1, 1), ws1.Cells(k, j)).Copy
ws2.Activate
ws2.Cells(1, 1).Select
ActiveSheet.Paste
Range(ws2.Columns(1), ws2.Columns(j)).AutoFit
ws1.Activate
ws1.Cells(1, 1).Select
Selection.AutoFilter
ws1.Cells(1, 1).Select
Else
MsgBox "データがありません。"
End If
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

お礼

ショートカット方法など細かい配慮ありがとうございます。
しかし申し訳ないですが、最初に答えていただいかたにベストアンサーを送りたいと思います。
機会あればまたよろしくお願いします。