エクセルのマクロの質問です。来店客の購入履歴を「来店記録」、会員登録してもらった顧客情報を「顧客名簿」というファイルに記録しています。「来店記録」内で入力した顧客に関する名前、会員番号等のキーワードを「顧客名簿」から探し出すという顧客検索マクロを作りたいと考えています。現在はオートフィルタ機能のオプションで検索しています。全角/半角スペースがある場合には”?”を入れたりしていて手間取ります。店頭で顧客に対応する時、即時性が求められるので操作のステップ数を減らしたいと思います。

ほとんど 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 さんの回答から判断すると、一つのファイル内で処理をしているように見え

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

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

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

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

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

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

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

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

コード自体は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