人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルのマクロの質問です。来店客の購入履歴を「来店記録」、会員登録してもらった顧客情報を「顧客名簿」というファイルに記録しています。「来店記録」内で入力した顧客に関する名前、会員番号等のキーワードを「顧客名簿」から探し出すという顧客検索マクロを作りたいと考えています。現在はオートフィルタ機能のオプションで検索しています。全角/半角スペースがある場合には”?”を入れたりしていて手間取ります。店頭で顧客に対応する時、即時性が求められるので操作のステップ数を減らしたいと思います。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のため「顧客名簿」のサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:エクセル オプション キーワード コメント コード
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● Mook
●750ポイント

ほとんど SALINGER さん以外は正確な状況を把握できないと思いますが、

面白そうなので下記のコメントの範囲で回答してみました。


きっと、SALINGERさんの完璧な回答がつくとは思いますが、いろいろなやり方があるということで。


Option Explicit

Sub MacroClientSearch()
 Dim srcWS As Worksheet  '--- 検索元シート
 Dim dstWS As Worksheet  '--- 検索先シート
 Dim srcTitle As String  '--- 検索タイトル
 Dim dstTitleRange As Range  '--- 検索先タイトル
 Dim dstTitleRangeBK As Range  '--- 検索先タイトル保存用
 Dim searchWord As String  '--- 検索ワード
 Dim searchWordBK As String  '--- 検索ワード保存用
 Dim count As Long  '--- 検索ヒット数

'--- 作業用変数
 Dim sWord As Variant
 Dim swords As Variant
 Dim lastRow As Long
 Dim i As Long
 Dim rg As Range

'--- 複数セル選択した場合のエラー処理
 If Selection.count <> 1 Then
 MsgBox ("複数のセルが選択されています。")
 Exit Sub
 End If
 
 Set srcWS = ActiveSheet
 Set dstWS = Worksheets("顧客名簿")
 
 srcTitle = srcWS.Cells(1, Selection.Column).Value
 searchWord = Selection.Value
'--- タイトル列がない場合の処理
 If Len(srcTitle) = 0 Then
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 
'--- 検索先にタイトル列がない場合の処理
 Set dstTitleRange = dstWS.Rows(1).Find(what:=srcTitle, lookat:=xlWhole)
 If dstTitleRange Is Nothing Then
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 
'--- 検索語の準備処理
 Select Case dstTitleRange.Value
 Case "会員番号"
 Case "旧会員番号"
 searchWordBK = searchWord
 Set dstTitleRangeBK = dstTitleRange
 dstWS.Columns(100).Clear
 dstWS.Cells(1, 100).Value = "○"
 swords = Split(searchWord, "/")
 lastRow = dstWS.Cells(Rows.count, dstTitleRange.Column).End(xlUp).Row
 For Each sWord In swords
 For i = 2 To lastRow
 If InStr("/" & dstWS.Cells(i, dstTitleRange.Column) & "/", "/" & Trim(sWord) & "/") > 0 Then
 dstWS.Cells(i, 100).Value = "○"
 End If
 Next
 Next
 searchWord = "○"
 Set dstTitleRange = dstWS.Cells(1, 100)
 Case "名前", "フリガナ"
 searchWord = Replace(searchWord, " ", "*")  '--- 半角スペースの置換
 searchWord = Replace(searchWord, " ", "*")  '--- 全角スペースの置換
 Case "電話番号"
 searchWord = Replace(searchWord, "-", "?")  '--- 半角ハイフンの置換
 searchWord = Replace(searchWord, "―", "?")  '--- 全角ハイフンの置換
 Case "メール", "携帯メール"
 Case Else
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End Select
 
 
'--- 検索処理
 dstWS.Activate
 If dstWS.AutoFilterMode = True Then
 dstWS.Range("A1").AutoFilter
 End If
 dstWS.Columns(dstTitleRange.Column).AutoFilter Field:=1, Criteria1:=searchWord
 
 lastRow = dstWS.Cells(Rows.count, dstTitleRange.Column).End(xlUp).Row
 If dstTitleRange.Column = 100 Then
 searchWord = searchWordBK
 Set dstTitleRange = dstTitleRangeBK
 End If
 
'--- 検索結果がない場合
 If lastRow = 1 Then
 MsgBox "検索キーワード「" & searchWord & "」に該当する行は見つかりませんでした。" _
 & "検索条件を変えてみてください。"
 dstWS.Range("A1").AutoFilter
 srcWS.Activate
 Exit Sub
 End If
 
'--- 検索結果があった場合
 dstTitleRange.Offset(1).Resize(lastRow - 1, 1).SpecialCells(xlVisible).Select
 For Each rg In Selection
 count = count + 1
 Next
 If MsgBox("検索キーワード「" & searchWord & "」に該当する " & count & " 行を表示しました。" _
 & vbNewLine & "最初のページに戻りますか?", _
 vbYesNo, "最初のページに戻りますか?") = vbYes Then
 dstWS.Range("A1").AutoFilter
 srcWS.Activate
 End If
End Sub

若干不安な点があるので、何点かコメントです。

・これまでのSALINGER さんの回答から判断すると、一つのファイル内で処理をしているように見え

ましたので、今回もそのように作成しています。

ただ、質問文を読むと複数ファイルがあるように書かれています。

その場合、各ファイル名とシート名がはっきりしないと回答できませんでしたので、今回は各名称を

シート名と解釈しています。


・旧会員番号は、通常のフィルタ(3項目以上は不可)では処理できませんので、作業列(100列目)を

使用しています。このためこの項目はフィルタマークが見えません。


もし修正すべき点がありましたら、コメントください。


2 ● SALINGER
●0ポイント

今回顧客名簿を照会するファイルは異なるブックということなので、その部分だけを作ってみました。

コード自体はMookさんのコードがすばらしかったのでそのまま転用させていただきました。

通販管理、来店記録それぞれのブックの標準モジュールにコピペしてください。

便宜上、顧客名簿のブック名を「顧客名簿.xls」(拡張子が表示されない設定ならば「顧客名簿」にしてください。)

顧客名簿があるシートを「顧客名簿」としています。

コードの最初の部分をお使いの環境に変更してください。

Option Explicit

Sub MacroClientSearch()
  '顧客名簿のパスを環境に合わせてください
 Const myPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\顧客名簿.xls"
  '顧客名簿のブック名
 Const wbName As String = "顧客名簿.xls"
  '顧客名簿のワークシート名
 Const wsName As String = "顧客 名簿"
 
 Dim srcWS As Worksheet  '--- 検索元シート
 Dim dstWS As Worksheet  '--- 検索先シート
 Dim srcTitle As String  '--- 検索タイトル
 Dim dstTitleRange As Range  '--- 検索先タイトル
 Dim dstTitleRangeBK As Range  '--- 検索先タイトル保存用
 Dim searchWord As String  '--- 検索ワード
 Dim searchWordBK As String  '--- 検索ワード保存用
 Dim count As Long  '--- 検索ヒット数

'--- 作業用変数
 Dim sWord As Variant
 Dim swords As Variant
 Dim lastRow As Long
 Dim i As Long
 Dim rg As Range

'--- 複数セル選択した場合のエラー処理
 If Selection.count <> 1 Then
 MsgBox ("複数のセルが選択されています。")
 Exit Sub
 End If
 
 Set srcWS = ActiveSheet
 
 srcTitle = srcWS.Cells(1, Selection.Column).Value
 searchWord = Selection.Value
'--- タイトル列がない場合の処理
 If Len(srcTitle) = 0 Then
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 
 On Error GoTo Err_Mes
 If bookCheck(myPath) Then
 Set dstWS = Workbooks(wbName).Worksheets(wsName)
 Else
 Set dstWS = Workbooks.Open(myPath).Worksheets(wsName)
 End If
 On Error GoTo 0
 
'--- 検索先にタイトル列がない場合の処理
 Set dstTitleRange = dstWS.Rows(1).Find(what:=srcTitle, lookat:=xlWhole)
 If dstTitleRange Is Nothing Then
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 
'--- 検索語の準備処理
 Select Case dstTitleRange.Value
 Case "会員番号"
 Case "旧会員番号"
 searchWordBK = searchWord
 Set dstTitleRangeBK = dstTitleRange
 dstWS.Columns(100).Clear
 dstWS.Cells(1, 100).Value = "○"
 swords = Split(searchWord, "/")
 lastRow = dstWS.Cells(Rows.count, dstTitleRange.Column).End(xlUp).Row
 For Each sWord In swords
 For i = 2 To lastRow
 If InStr("/" & dstWS.Cells(i, dstTitleRange.Column) & "/", "/" & Trim(sWord) & "/") > 0 Then
 dstWS.Cells(i, 100).Value = "○"
 End If
 Next
 Next
 searchWord = "○"
 Set dstTitleRange = dstWS.Cells(1, 100)
 Case "名前", "フリガナ"
 searchWord = Replace(searchWord, " ", "*")  '--- 半角スペースの置換
 searchWord = Replace(searchWord, " ", "*")  '--- 全角スペースの置換
 Case "電話番号"
 searchWord = Replace(searchWord, "-", "?")  '--- 半角ハイフンの置換
 searchWord = Replace(searchWord, "―", "?")  '--- 全角ハイフンの置換
 Case "メール", "携帯メール"
 Case Else
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End Select
 
 
'--- 検索処理
 dstWS.Activate
 If dstWS.AutoFilterMode = True Then
 dstWS.Range("A1").AutoFilter
 End If
 dstWS.Columns(dstTitleRange.Column).AutoFilter Field:=1, Criteria1:=searchWord
 
 lastRow = dstWS.Cells(Rows.count, dstTitleRange.Column).End(xlUp).Row
 If dstTitleRange.Column = 100 Then
 searchWord = searchWordBK
 Set dstTitleRange = dstTitleRangeBK
 End If
 
'--- 検索結果がない場合
 If lastRow = 1 Then
 MsgBox "検索キーワード「" & searchWord & "」に該当する行は見つかりませんでした。" _
 & "検索条件を変えてみてください。"
 dstWS.Range("A1").AutoFilter
 srcWS.Activate
 Exit Sub
 End If
 
'--- 検索結果があった場合
 dstTitleRange.Offset(1).Resize(lastRow - 1, 1).SpecialCells(xlVisible).Select
 For Each rg In Selection
 count = count + 1
 Next
 If MsgBox("検索キーワード「" & searchWord & "」に該当する " & count & " 行を表示しました。" _
 & vbNewLine & "最初のページに戻りますか?", _
 vbYesNo, "最初のページに戻りますか?") = vbYes Then
 dstWS.Range("A1").AutoFilter
 srcWS.Activate
 End If
 Exit Sub
 
Err_Mes:
 Select Case Err.Number
 Case 1004
 MsgBox "顧客管理をオープンできません。パスを確認してください。"
 Case 9
 MsgBox "顧客管理の正しいブック名とシート名を指定してください。"
 Case Else
 MsgBox "顧客管理をオープンすることができませんでした。"
 End Select
End Sub

'ブックが開いているかをチェック
Function bookCheck(myPath As String) As Boolean
 Dim f As Boolean
 Dim myBook As Workbook
 For Each myBook In Workbooks
 If myBook.Path & "\" & myBook.Name = myPath Then
 f = True
 Exit For
 End If
 Next
 bookCheck = f
End Function
◎質問者からの返答

> SALINGERさん

ご回答ありがとうございます。

希望通りの動作を確認できました。

本当にありがとうございます。

最後に一点だけ思わぬ動作をするところがあるのでこの部分の修正をすることは可能でしょうか?

会員カードを忘れた顧客から会員番号の問合せを受けることがあります。

この場合「顧客名簿」の最終行に検索キーワードを入力し、マクロを実行します。

▼以下のメッセージが表示され、[はい]を選択すると、検索キーワードを入力したセルに戻らず、いちばん上の1行目から表示されます。

最初のページに戻りますか?

[はい]→最初のページに戻って検索をやり直す/検索を終了する。

[いいえ]→このページの検索結果を確認する。”

[はい][いいえ]

これだと次の検索を始める時に毎回最終行まで戻らなければなりません。

1万行ほどあるため、最終行まで戻るのが面倒です。

[はい]を選択しても検索を始めたセルに戻ることは可能でしょうか?

なお検索キーワードを含む行が検索ページ内にあると、このようなことは生じません。

行数が1ページを超える場合にこのようになります。

お手数をおかけしますがチェックしてみていただいてもよろしいでしょうか。

よろしくお願いいたします。


3 ● SALINGER
●750ポイント ベストアンサー

Mookさんのコードに手を入れさせていただいて、条件に合うようにしてみるとこんな感じかな。

電話番号の為に101列目を使いました。

Sub MacroClientSearch()
  '顧客名簿のパスを環境に合わせてください
 Const myPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\顧客名簿.xls"
  '顧客名簿のブック名
 Const wbName As String = "顧客名簿.xls"
  '顧客名簿のワークシート名
 Const wsName As String = "顧客名簿"
 
 Dim srcWS As Worksheet  '--- 検索元シート
 Dim dstWS As Worksheet  '--- 検索先シート
 Dim srcTitle As String  '--- 検索タイトル
 Dim dstTitleRange As Range  '--- 検索先タイトル
 Dim dstTitleRangeBK As Range  '--- 検索先タイトル保存用
 Dim searchWord As String  '--- 検索ワード
 Dim searchWordBK As String  '--- 検索ワード保存用
 Dim count As Long  '--- 検索ヒット数

'--- 作業用変数
 Dim sWord As Variant
 Dim swords As Variant
 Dim lastRow As Long
 Dim i As Long
 Dim rg As Range

'--- 複数セル選択した場合のエラー処理
 If Selection.count <> 1 Then
 MsgBox ("複数のセルが選択されています。")
 Exit Sub
 End If
 
 Set srcWS = ActiveSheet
 
 srcTitle = srcWS.Cells(1, Selection.Column).Value
 searchWord = Selection.Value
'--- タイトル列がない場合の処理
 If Len(srcTitle) = 0 Then
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 
 On Error GoTo Err_Mes
 If bookCheck(myPath) Then
 Set dstWS = Workbooks(wbName).Worksheets(wsName)
 Else
 Set dstWS = Workbooks.Open(myPath).Worksheets(wsName)
 End If
 On Error GoTo 0
 
'--- 検索先にタイトル列がない場合の処理
 Set dstTitleRange = dstWS.Rows(1).Find(what:=srcTitle, lookat:=xlWhole)
 If dstTitleRange Is Nothing Then
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 
'--- 検索語の準備処理
 Select Case dstTitleRange.Value
 Case "会員番号"
 searchWord = StrConv(searchWord, vbNarrow)
 Case "旧会員番号"
 searchWord = StrConv(searchWord, vbNarrow)
 searchWordBK = searchWord
 Set dstTitleRangeBK = dstTitleRange
 dstWS.Columns(100).Clear
 dstWS.Cells(1, 100).Value = "○"
 swords = Split(searchWord, "/")
 lastRow = dstWS.Cells(Rows.count, dstTitleRange.Column).End(xlUp).Row
 For Each sWord In swords
 For i = 2 To lastRow
 If InStr("/" & dstWS.Cells(i, dstTitleRange.Column) & "/", "/" & Trim(CStr(sWord)) & "/") > 0 Then
 dstWS.Cells(i, 100).Value = "○"
 End If
 Next
 Next
 searchWord = "○"
 Set dstTitleRange = dstWS.Cells(1, 100)
 Case "名前", "フリガナ"
 searchWord = Replace(searchWord, " ", "*")  '--- 半角スペースの置換
 searchWord = Replace(searchWord, " ", "*")  '--- 全角スペースの置換
 Case "電話番号"
 searchWord = haifun(searchWord)
 searchWordBK = searchWord
 Set dstTitleRangeBK = dstTitleRange
 dstWS.Columns(101).Clear
 dstWS.Cells(1, 101).Value = "○"
 lastRow = dstWS.Cells(Rows.count, dstTitleRange.Column).End(xlUp).Row
 For i = 2 To lastRow
 swords = Split(dstWS.Cells(i, dstTitleRange.Column).Value, "/")
 For Each sWord In swords
 If haifun(CStr(sWord)) = searchWord Then
 dstWS.Cells(i, 101).Value = "○"
 End If
 Next
 Next
 searchWord = "○"
 Set dstTitleRange = dstWS.Cells(1, 101)
 Case "メール", "携帯メール"
 searchWord = StrConv(searchWord, vbNarrow)
 Case Else
 MsgBox searchWord & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End Select
 
 
'--- 検索処理
 dstWS.Activate
 If dstWS.AutoFilterMode = True Then
 dstWS.Range("A1").AutoFilter
 End If
 dstWS.Columns(dstTitleRange.Column).AutoFilter Field:=1, Criteria1:=searchWord
 
 lastRow = dstWS.Cells(Rows.count, dstTitleRange.Column).End(xlUp).Row
 If dstTitleRange.Column = 100 Or dstTitleRange.Column = 101 Then
 searchWord = searchWordBK
 Set dstTitleRange = dstTitleRangeBK
 End If
 
'--- 検索結果がない場合
 If lastRow = 1 Then
 MsgBox "検索キーワード「" & searchWord & "」に該当する行は見つかりませんでした。" _
 & "検索条件を変えてみてください。"
 dstWS.Range("A1").AutoFilter
 srcWS.Activate
 Exit Sub
 End If
 
'--- 検索結果があった場合
 dstTitleRange.Offset(1).Resize(lastRow - 1, 1).SpecialCells(xlVisible).Select
 For Each rg In Selection
 count = count + 1
 Next
 If MsgBox("検索キーワード「" & searchWord & "」に該当する " & count & " 行を表示しました。" _
 & vbNewLine & "最初のページに戻りますか?" & vbNewLine & _
 "[はい]→最初のページに戻って検索をやり直す/検索を終了する。" & vbNewLine & _
 "[いいえ]→このページの検索結果を確認する。", _
 vbYesNo, "最初のページに戻りますか?") = vbYes Then
 dstWS.Range("A1").AutoFilter
 srcWS.Activate
 End If
 Exit Sub
 
Err_Mes:
 Select Case Err.Number
 Case 1004
 MsgBox "顧客管理をオープンできません。パスを確認してください。"
 Case 9
 MsgBox "顧客管理の正しいブック名とシート名を指定してください。"
 Case Else
 MsgBox "顧客管理をオープンすることができませんでした。"
 End Select
End Sub

'ブックが開いているかをチェック
Function bookCheck(myPath As String) As Boolean
 Dim f As Boolean
 Dim myBook As Workbook
 For Each myBook In Workbooks
 If myBook.Path & "\" & myBook.Name = myPath Then
 f = True
 Exit For
 End If
 Next
 bookCheck = f
End Function

'半角にして?を削除
Function haifun(str As String) As String
 str = StrConv(str, vbNarrow)
 str = Replace(str, "-", "")
 str = Replace(str, "―", "")
 str = Replace(str, "ー", "")
 str = Replace(str, "?", "")
 haifun = str
End Function

コード中の「\」は¥(半角)に置き換えてください。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ