ＥＸＣＥＬで顧客管理

既に出ているご回答が長いので、短くならないかやって見ました。
２５行程度になりました。ただ下記は至らぬ点があります。
（１）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４に
大木　茂　　　　　　　笠岡市２６歳
大木　武雄下関市４３歳
大木　広　　　　　　　長野市３３歳
と検索結果が出ます。（以上テスト済。エクセル２０００で。）

投稿日時 - 2002-06-22 18:08:41

シートでの処理－１
１．データは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

投稿日時 - 2002-06-21 16:52:14