ＥＸＣＥＬで顧客管理

質問

ＥＸＣＥＬで顧客管理をしたいと思います。
一行に・・・
　名前、フリガナ、郵便番号、住所、生年月日・・・・・・
と一つずつのセルに入力してあります。
５００名分を７シートに分けて打ち込んであります。

(1)「フリガナ」の２文字を入力すると適合する顧客が別シートに一覧として表示されるようにしたい。
(2)「フリガナ」を入力して・・・という作業をする入力フォームを作りたい。
（フリガナを入力する→検索ボタンをクリック→表に一覧が表示されるといった形式のもの）

以上、２点について教えていただければ幸いです。
これは可能なことなのかもよくわかりませんがよろしくお願いします。

回答No.1

misatoanna · ベストアンサー

次の参考マクロは、顧客リストのシートを "Sheet1"、抽出用シート名を "Sheet9" とした場合です。
不得意分野ですので、スマートではありませんが、参考にしてください。
まず、住所録データの入ったブックを呼び出して、VB Editor の標準モジュールに下記のコマンドをコピペしてください。
ここでは、Sheet1は、Ａ列から「名前」「よみ」「郵便番号」「住所」の順に並んでいて、見出し行なしでデータは１行目から入っていると仮定していますので、実験用として、データをそのように加工してください。
また、Sheet9 を作成してください。
'---- コピーは次行から -------
Sub LstMk()
OPL = 0
Application.ScreenUpdating = False
Yomi = InputBox("名前の読み二文字を入力して下さい")
' ※
Worksheets("Sheet1").Select
LL = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
For DTL = 1 To LL
Worksheets("Sheet1").Select
Cells(DTL, 2).Select
DT8 = ActiveCell
If Left(DT8, 2) = Yomi Then
OPL = OPL + 1
Cells(DTL, 1).Select
名前 = ActiveCell
Cells(DTL, 3).Select
郵便 = ActiveCell
Cells(DTL, 4).Select
住所 = ActiveCell
Worksheets("Sheet9").Select
Cells(OPL, 1).Select
ActiveCell.FormulaR1C1 = 名前
Cells(OPL, 2).Select
ActiveCell.FormulaR1C1 = DT8
Cells(OPL, 3).Select
ActiveCell.FormulaR1C1 = 郵便
Cells(OPL, 4).Select
ActiveCell.FormulaR1C1 = 住所
End If
Next DTL
' ※
' ＃
Worksheets("Sheet1").Select
Application.ScreenUpdating = True
End Sub
'---- コピーは前行まで -------
コピー後　VB Editor を閉じ、[ツール]-[マクロ]-[マクロ] から、LstMk を実行し、処理終了後に Sheet2 を開いてみてください。
++++++++++++++++
データシートは１枚を仮定しています。お手持ちのようにデータが複数シート(同様式)の場合は、上コマンドの "※"～"※" を シート名を変えて繰り返せばよいでしょう。

お礼

ありがとうございます！！只今作業途中ですが御礼だけ先にいたしますね。
コピーができましたので加工中です。
自分で必死に調べてもどうつなぎ合わせてどうやれば・・・と頭が混乱していました。一つの理屈にまとめて教えていただいたので脳みそがスッキリしました。
初心者の私には神様の様です！！
がんばって作ります。

回答No.3

imogasi

既に出ているご回答が長いので、短くならないかやって見ました。
２５行程度になりました。ただ下記は至らぬ点があります。
（１）Sheet1からSheet7までの範囲を続けて検索する技術が
　　判らず、対応が出来ていない。致命的か？ご存知の方は
　　教えて頂ければと思います。Sheets(Arｒay（”Shｅet1","Sheet2")）　　・・・・が上手く行かなかった。
（２）カナ名索引の例でない。これは下記を少し変えて、直すことがで　　きる。漢字名検索の方を勧めますが。
　なお漢字名の一部でも検索してくることは確認済。（「大木　武」
　　で検索すると「大木　武雄」だけ出る。）
（３）結果をフォームに表示していない。検索氏名をフォームで
　　聞いていない。これに対しては使っていないシートをフォームのよ　　うに使うとかで切りぬけられる（VBと違いユーザーフォームがエク　　セルVBAでは許されていない（？）ようなので）。売り物でなけれ　　ばInputboxで我慢できるのでは。
－－－－－
テストデータとしてA1:C13に下記のデータを入力。
氏名録
黒石　明 　　　　　　北区 ２４歳
山田　治夫 大阪市 ３５歳
金田　俊夫 大阪市 ２３歳
上野　義男 金沢市 ２０歳
大田　信夫 新潟市 ２２歳
安田　寛 　　　　　　　丹後市 ５６歳
澤田　建次 岡山市 ３３歳
大木　茂 　　　　　　　笠岡市 ２６歳
大木　武雄 下関市 ４３歳
山田　謙 　　　　　　　北上市 ２２歳
栗本　裕二 甲府市 ５６歳
VBEのModule1に
Sub Testo1()
Sheets("sheet1").Select
Range("e2:g13").ClearContents
l = Range("a2").CurrentRegion.Rows.Count
i = 2
x = InputBox("名前＝")
Set c = Range(Cells(2, 1), Cells(l, 1)).Find(What:=x, LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False)
If Not c Is Nothing Then
fadr = c.Address
Do
Worksheets("sheet1").Cells(i, 5) = c.Offset(0, 0)　'a
Worksheets("sheet1").Cells(i, 6) = c.Offset(0, 1) 'b
Worksheets("sheet1").Cells(i, 7) = c.Offset(0, 2) 'c
i = i + 1
Set c = Range(Cells(2, 1), Cells(l, 1)).FindNext(c)
If c.Address = fadr Then Exit Do
Loop
End If
End Sub
実行して「氏名＝」と聞いてくるので、「大木」と入力。
E2:G４に
大木　茂 　　　　　　　笠岡市 ２６歳
大木　武雄 下関市 ４３歳
大木　広 　　　　　　　長野市 ３３歳
と検索結果が出ます。（以上テスト済。エクセル２０００で。）

お礼

出掛けておりまして御礼が遅くなってすみません。
ありがとうございました。
このくらいの長さだと、コピー貼り付けではなく自分で一つ一つ入力できるのでとても勉強になりました。かなり満足のいくものができました。感謝！！！です。

回答No.2

nishi6

シートでの処理－１
１．データは500名くらいで、シートは複数枚あるとします。(同じ形式なら何枚でもいいですが)
２．各シートは同一形式で１行目は表題、２行目からデータが入っているとします。
３．一覧表示させるシートを挿入してシート名『抽出』を付けます。

VBE画面での処理（ユーザーフォームを作ります）
１．ツール→マクロ→Visual Basic Editor でVBE画面に移り、挿入→ユーザーフォーム（UserForm1）
２．表示→ツールボックスでツールボックスを出して、このユーザーフォームに
　　　テキストボックス(TextBox1)とコマンドボタン(CommandButton1)を作ります。
　　　　TextBox1を右クリックして、プロパティを選択
　　　　　IMEMode を 5 - fmIMEModekatakana に
　　　　CommandButton1を右クリックして、プロパティを選択
　　　　　Caption を『抽出』に
　　　　　Default を True にする。
３．CommandButton1をダブルクリックすると、ユーザーフォームのコードウインドウに
　　　Private Sub CommandButton1_Click()

　　　End Sub
　　ができるので、下のコード（※）をコピーして貼り付ける。

　　startCol = "C" にデータ登録の開始列をセットします。今はC列からデータがある事にしています。
　　Koumoku = 7　　にデータの項目数をセットします。今は１行に７項目あるとしています。
　　FuriCol = 2　　にフリガナが左から何番目にあるかセットします。今はD列にあり２番目です。

シートでの処理－２
１．シート『抽出』に戻ります。
２．表示→ツールバー→Visual Basic で Visual Basicのツールバーを表示。
３．コントロールツールボックスをクリック
４．コントロールツールボックスのコマンドボタンをクリックして、シート上にボタンを１つ作成。
５．ボタンの見た目は右クリックしてプロパティを選択して設定します。
６．ボタンは小さくして、１行目の左辺りに置いていたほうがいいでしょう。
７．ボタンをダブルクリック。（またVBE画面になる）
８．シート『抽出』のコードウインドウが
　　Private Sub CommandButton1_Click()

　　End Sub
　　なっているので、下のように書く。
　　Private Sub CommandButton1_Click()
　　　　UserForm1.Show
　　End Sub
９．シート『抽出』に戻ります。
10．コントロールツールボックスを閉じる。
　　デザインモードになっていたら解除する。

これでできているはず・・・・です。一応、別名で保存してボタンを押します。
何よりも説明が一番難しいですね。(当方Excel97です)

　　『フリガナの２文字と適合』については、入力した文字がフリガナの中にあれば抽出しています。
　　これを先頭からのみの照合に限定するなら下記のようにします。
　　　　If InStr(.Cells(rw, fCol), inpFuri) >= 1 Then
　　　　　↓
　　　　If InStr(.Cells(rw, fCol), inpFuri) = 1 Then

（※）ユーザーフォームのコードウインドウに貼り付け
　↓
Private Sub CommandButton1_Click()
　　Const startCol = "C" 'データ登録の開始列
　　Const Koumoku = 7 '項目数
　　Const FuriCol = 2 'フリガナは左から何番目？

　　Dim sCol As Integer '開始列
　　Dim fCol As Integer 'フリガナがある列
　　　　sCol = Range(startCol & "2").Column
　　　　fCol = Range(startCol & "2").Column + FuriCol - 1
　　　　Range(Cells(2, sCol), Cells(500, sCol + Koumoku - 1)).ClearContents

　　Dim rw As Long, rwOut As Long '検索行と出力行
　　Dim inpFuri As String '指定したフリガナ2文字(3文字でもいい)
　　Dim ws As Worksheet 'データ入力されたシート
　　Dim wsOut As Worksheet '抽出結果の出力シート
　　　　Set wsOut = Worksheets("抽出")
　　　　inpFuri = TextBox1.Text

　　Application.ScreenUpdating = False
　　ActiveCell.Activate
　　rwOut = 1
　　For Each ws In Worksheets
　　　　If ws.Name <> "抽出" Then
　　　　　　rw = 2
　　　　　　With ws
　　　　　　　　While .Cells(rw, fCol) <> "" 'セルを調べる
　　　　　　　　　　If InStr(.Cells(rw, fCol), inpFuri) >= 1 Then
　　　　　　　　　　　　rwOut = rwOut + 1
　　　　　　　　　　　　.Range(.Cells(rw, sCol), .Cells(rw, sCol + Koumoku - 1)).Copy _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Destination:=wsOut.Cells(rwOut, sCol)
　　　　　　　　　　End If

　　　　　　　　　　rw = rw + 1
　　　　　　　　Wend
　　　　　　End With
　　　　End If
　　Next
　　Application.ScreenUpdating = True

　　Me.Hide
End Sub

お礼

ありがとうございます！！
これまた親切な御指導で感激してます。
わかりやすいですね。
これから必死にやってみます。
とりあえず御礼だけさせていただきます。
感謝です。