データベースを検索するマクロ（エクセルで）

質問

エクセル初級者です。
データベース化してある顧客名簿がｓｈｅｅｔ２にあり、Ａ列は個人別コードが、Ｂ列は氏名、Ｃ列は郵便番号、Ｄ列は住所、・・・といった感じになってます。

教えていただきたいのは、ｓｈｅｅｔ１上で氏名を入力して検索するフォームを作り、検索の結果、ヒットしたすべてがｓｈｅｅｔ３上に抜き出す方法って可能ですか？

うまくいえないのですが、例えば「佐藤」と入力して検索ボタンを押せば、ｓｈｅｅｔ２のすべての佐藤さんのデータがｓｈｅｅｔ２の形式と同じ形でｓｈｅｅｔ３に表示されるようにしたいのです。
情報に不足があれば補足しますので、どなたかＶＢＡの書き方を教えてください。よろしくお願い致します。

回答No.2

Musaffah · ベストアンサー

すいません。このマクロの詳細を説明する時間がありませんので、メンテナンス性も考慮したバージョンアップ版のVBAマクロを作成しました。こちらを使ってみてください。
違いは１行目に"氏名"の欄がある列番号を自動で取得するようにしました。これで、住所録（なのかな？）の列情報が思いっきり変更になっても、"氏名"の列を見つけてくれます。

もし"氏名"以外の文字にするのなら、
>Set sName = wsAdr.Cells.Find(What:="氏名")
の"氏名"のところを変更してください。
Findメソッドとはその名のとおり［検索］です。
"氏名"と書かれたセルを取得し、そのセルの列番号を取得（iColName変数に代入）するようにしています。詳細はヘルプを見ればわかると思います。
また、セルの場所はcells([行番号],[列番号])で指定しています。

Public Sub 検索実行()
Dim wsInp, wsAdr, wsOut As Worksheet
Dim strFindName As String
Dim iColName As Integer
Dim iColNum As Integer
Dim iRowWrt As Integer
Dim i, j As Integer
Dim sName As Range

Set wsInp = Worksheets("Sheet1")
Set wsAdr = Worksheets("Sheet2")
Set wsOut = Worksheets("sheet3")

'検索する氏名を取得
strFindName = InputBox("検索する名前は？", "氏名の入力")
If Len(Trim(strFindName)) = 0 Then Exit Sub

'"氏名"列番号の自動取得
Set sName = wsAdr.Cells.Find(What:="氏名")
If sName Is Nothing Then
MsgBox "[氏名]欄がありません！", vbOKOnly, "エラー"
Exit Sub
Else
iColName = sName.Column
End If

'抽出する列の数を取得
iColNum = 1
While Len(Trim(wsAdr.Cells(1, iColNum))) <> 0
iColNum = iColNum + 1
Wend
iColNum = iColNum - 1

'見出し行のコピー＆列幅調整
wsAdr.Rows(1).Copy Destination:=wsOut.Rows(1)
For j = 1 To iColNum
wsOut.Columns(j).ColumnWidth = wsAdr.Columns(j).ColumnWidth
Next j

'検索＆書き込み開始
iRowWrt = 2
i = 2
While Len(Trim(wsAdr.Cells(i, iColName))) <> 0 '"氏名"列にデータがあるまで
If InStr(1, wsAdr.Cells(i, iColName), strFindName) > 0 Then '同じ氏名？
wsAdr.Rows(i).Copy Destination:=wsOut.Rows(iRowWrt) '行を丸ごとコピー
iRowWrt = iRowWrt + 1 '書き込み行再設定
End If
i = i + 1
Wend

If iRowWrt = 2 Then '１行でも該当する氏名はあった？
MsgBox "該当する氏名はありませんでした。", vbOKOnly, "検索結果"
Else
MsgBox "該当する氏名は" & StrConv(CStr(iRowWrt - 2), vbWide) & "名いました。", vbOKOnly, "検索結果"
End If
End Sub

お礼

お忙しいところ再度丁寧に回答いただきありがとうございました。
無事に起動でき大変感謝しております。

また質問のときはよろしくお願いいたします。

回答No.1

Musaffah

hama21さん。

取り急ぎ簡単にVBAマクロ作って見ました。
これを標準モジュールにコピーして実行すると、氏名の入力を促すパネルが表示されます。そこで氏名（苗字・名前だけでも可能）を入力して[OK]を押すと、Sheet3に該当する氏名(入力した文字がある名前の人)の情報を出力（コピー）してくれます。何も入力しないか[キャンセル]ボタンをクリックするとそのまま終了します。
あと、データの列の見出しの数を調べて、列幅・フォント・文字色等もそのままコピーしてくれます。

こんなんでよろしいでしょうか？
何か勘違いしてたらごめんなさい。

Public Sub 検索実行()
Dim wsInp, wsAdr, wsOut As Worksheet
Dim strFindName As String
Dim iColNum As Integer
Dim iRowWrt As Integer
Dim i, j As Integer

Set wsInp = Worksheets("Sheet1")
Set wsAdr = Worksheets("Sheet2")
Set wsOut = Worksheets("sheet3")

'検索する氏名を取得
strFindName = InputBox("検索する名前は？", "氏名の入力")
If Len(Trim(strFindName)) = 0 Then Exit Sub

'抽出する列の数を取得
iColNum = 1
While Len(Trim(wsAdr.Cells(1, iColNum))) <> 0
iColNum = iColNum + 1
Wend
iColNum = iColNum - 1

'見出し行のコピー
wsAdr.Rows(1).Copy Destination:=wsOut.Rows(1)
For j = 1 To iColNum
wsOut.Columns(j).ColumnWidth = wsAdr.Columns(j).ColumnWidth
Next j

'検索＆書き込み開始（氏名の列を数字で指定）
iRowWrt = 2
i = 2
While Len(Trim(wsAdr.Cells(i, 2))) <> 0
If InStr(1, wsAdr.Cells(i, 2), strFindName) > 0 Then
wsAdr.Rows(i).Copy Destination:=wsOut.Rows(iRowWrt)
iRowWrt = iRowWrt + 1
End If
i = i + 1
Wend

If iRowWrt = 2 Then
MsgBox "該当する氏名はありませんでした。", vbOKOnly, "検索結果"
Else
MsgBox "該当する氏名は" & StrConv(CStr(iRowWrt - 2), vbWide) & "名いました。", vbOKOnly, "検索結果"
End If
End Sub

お礼

素人質問にこんなに詳しく回答いただきありがとうございます。まさしくこういうものが欲しかったので感謝しまくりです。

こんなに詳細にお答えいただけるとは思ってませんでしたので質問の文章を例示的に書いてしまったのが原因で検索範囲がズレているのだと思うのですが、実際にコピーしてマクロを実行してみると「該当する氏名はありませんでした。」になってしまいます。

もしお時間が許すのであれば、それぞれのコードの意味、アレンジの仕方をご指導いただけませんでしょうか？
二度手間をかけるようで申し訳ないのですがよろしくお願いいたします。