[[20250417133308]]　『VBA　品名検索（）が含まれなくても検索したい』（UNIKO）　ページの最後に飛ぶ

『VBA　品名検索（）が含まれなくても検索したい』（UNIKO）

1つ目のファイルのA2セルに品名を入れて、2つ目のファイルで一致する品名を探す記述をしていますが、
大文字でも小文字でも　‐ハイフンや（）カッコを入れても入れなくても検索できるようにしたいです。

現在は、A2セルで設定した文字数字の中にカッコ（）を設定しないと
別ファイルに（）が入っているため一致しないので、
メッセージを出すようにしています。
カッコ（）を入れなくても検索できるようにする記述はありますか。

検索したい品名）AB-A15B(W)　
検索時）A2セル　AB-A15B(W) でも　ABA15BW でも　aba15bw でも検索できるようにしたい

 Dim 品名

       If InStrRev(Range("A2"), "(") > 0 Then
     品名 = Left(Mid(Range("A2"), 4, 20), InStrRev(Mid(Range("A2"), 4, 20), "(") - 1)

     Else
     MsgBox "（）を入力してください"

     Exit Sub

      End If

・・・この後参照先のファイルの場所の記述が続きます。

＜使用 Excel：Microsoft365、使用 OS：Windows11 ＞

()を置き換えで取り払ったものを作成してLcaseとかに統一して
それと比較されてはどうでしょうか^^;
あと
正規表現とかでも。。。(￣▽￣)
m(__)m
（隠居Z） 2025/04/17(木) 14:35:14

 Option Explicit
Sub SampleA()
    Dim MySerchTarget() As Variant
    Dim MySerchKey() As Variant
    Dim i As Long
    Dim n As Long
    Dim dResult() As Variant
    Dim reg As Object
    Dim vAr, tA, tB
    Set reg = CreateObject("VBScript.RegExp")
    With reg
        .Pattern = "-|\(|\)"
        .Global = True
    End With
    MySerchKey = Array("AB-A15B(W)", "ABA15BW", "aba15bw")
    ReDim dResult(UBound(MySerchKey))
    MySerchTarget = Array("AC-VC(VQW)", "AB-A15B(W)", "QQQ(G)=Z", "AKANWA-123", _
                        "AH(AHAHAHA)", "EXXAB-A15B(W)", "II-DAROU(G)Z", "AKANWA-999")
    For Each vAr In MySerchKey
        tA = UCase(reg.Replace(vAr, ""))
        For i = 0 To UBound(MySerchTarget)
            tB = UCase(reg.Replace(MySerchTarget(i), ""))
            If tA = tB Then
                dResult(n) = vAr & " =  MATCH !"
            End If
        Next
        n = n + 1
    Next
    Set reg = Nothing
    MsgBox Join(dResult, Chr(13))
    Erase MySerchTarget, MySerchKey, dResult
End Sub
な
感じでせうか　(*^^*)
（隠居Z） 2025/04/17(木) 16:09:16

隠居Zさん　ありがとうございます。参照しに行くファイルのハイフンやカッコを置き返してもよいのですがそのファイルは基本触らない（提供されたもの）ので　それ以外の方法がいいなと思いました。
（UNIKO） 2025/04/17(木) 16:51:46

隠居Zさん
詳しくありがとうございます。
説明不足で申し訳なかったですが、
検索したい品名は　AB-A15B(W)　と記載しましたが品名は50～70くらいあります。　
3文字目までは共通（上の例ではAB- )のため4文字目から何文字を見る・・という感じにしております。
その場合の、記述を教えていただけないでしょうか。
（UNIKO） 2025/04/17(木) 17:01:09

 参照しに行くファイルの
 フルパス
 シート名
 検索範囲(列等)
 は判明していますか？
（jindon） 2025/04/17(木) 17:11:40

こんにちわ　＾＾
ファイル名は変えなくても。。。お借りして[変数に代入]それを加工しておりますので
上の例で申しますとファイル名に相当すると想像致します MySerchTarget配列の
要素の値は何一つ変えておりませんです。

ファイル名は変えなくてもと言いますか、意識して変えない限り、変わらないと存じますが
そういうお話ではないのでしょうか
尚　↑　の例では
品名の中の　-　と　(　と　)　を　消していますその他にも
消す文字列が有るのでしたら
.Pattern =
に追加すれば良いかと。。。
（jindon）さん　2025/04/17(木) 17:11:40
のご質問にお答えに成るとより明快なアドバイスが有ると思いますです。(*^^*)ｖ
でわ
m(__)m
（隠居Z） 2025/04/17(木) 17:18:54

jindonさん　隠居Zさん

ありがとうございます。

 参照しに行くファイルですが、
最初に記載した記述の下に続くのが以下の内容です。

    Dim ファイル名
    ファイル名 = Range("C30")

    Workbooks.Open Filename:="\\サーバ名\" & ファイル名, ReadOnly:=True

    Sheets("ファイル名").Select

    Call 位置検索(品名)

    Application.CutCopyMode = False

End Sub
（UNIKO） 2025/04/18(金) 13:20:58

 > 検索範囲(列等)
 > は判明していますか？

 >    Call 位置検索(品名)

 恐らくこの中身で判明すると思いますが？
（jindon） 2025/04/18(金) 13:26:10

jindon さん

Call 位置検索(品名)　は以下の通りです
ちなみに品名と日付（当日）に一致したとき色を付けるようにしています。

Application.ScreenUpdating = False

   Dim addfirst As String
   Dim addlast As String
   Dim DatDate As String

   Dim 列
   Dim 行

    ActiveWindow.FreezePanes = False
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    ActiveWindow.SmallScroll Down:=-3

   On Error Resume Next

    Set FoundCell = Range("f1:f5000").Find(What:=Date, LookIn:=xlFormulas)

     If FoundCell Is Nothing Then

         Set FoundCell = Range("f1:f50000").Find(What:=NEXTDAY, LookIn:=xlFormulas)

            If FoundCell Is Nothing Then
              msg = "No" & vbCrLf & "目視"
            End If

     End If

       列 = FoundCell.Column
       行 = FoundCell.Row

  Range(addfirst).Select
   With ActiveWindow
        .ScrollRow = ActiveCell.Row

    End With

   Rows("4:4").Select: ActiveWindow.FreezePanes = True

  Dim c As Object
  Dim myKey As String, fAddress As String
  Dim 範囲

  myKey = 品名

    Set FoundCell = Range("d1:d5000").Find(What:=myKey, LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, MatchByte:=False)

    If FoundCell Is Nothing Then

       MsgBox ("品名なし")

        Cells(行, 列).Select

           If ThisWorkbook.Sheets("sheet1").Range("L20") <> "表示しない" Then

              UserForm1.Top = 50   ' 画面の上から 50 ピクセル
              UserForm1.Left = 800
              UserForm1.Show

              Else
              End If

End

        Else: End If

      With ActiveSheet.Range("d" & 行 & ":d5000")
           Set c = .Find(What:=myKey, LookIn:=xlValues, LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, MatchByte:=False)

          If Not c Is Nothing Then
              fAddress = c.Address

              Do
                  c.Interior.ColorIndex = 4 
                   Set c = .FindNext(c)
                      If c.Address = fAddress Then Exit Do
              Loop

          End If

        End With

   i = c.Row

  Application.ScreenUpdating = True

  Range("d" & i).Select

    If ThisWorkbook.Sheets("sheet1").Range("L20") <> "表示しない" Then

      UserForm1.Top = 50   
      UserForm1.Left = 800
      UserForm1.Show

    Else
    End If

    Exit Sub

myError:

   If Err.Number <> 0 Then

    MsgBox "データなし"

     Cells(行, 列).Select

   Else
   End If
（UNIKO） 2025/04/18(金) 15:36:07

 Hummmm

 >ちなみに品名と日付（当日）に一致したとき色を付けるようにしています
 コードは
 1) f1:f50000に今日または明日の日付の存在を確認
 2) 
 > Range(addfirst).Select
 これエラーになりますね。 addfirstは常に空白です。
 3)
 1)の日付の存在が確認されたら、d列のその行からd5000に品名があれば全てに色を付けてます。

 即ち、日付の行と品名の行は必ずしも一致していません。

 具体的に何をどうしたいのか説明していただいた方が理解しやすいと思います。
（jindon） 2025/04/18(金) 17:29:19

jindonさん

ありがとうございます。
今の記述ですと、参照先（検索先）の品名は全て（）カッコが入っているのに、
A2に入力した品名に（）カッコを入れないで検索するとエラーになります。
カッコ（）が入っていなくても　品名が一致したら参照先の品名（日付・当日）に
色を塗りたいです。
※カッコ（）を入れれば問題なく参照できますし、小文字でも参照できます

 Dim 品名

       If InStrRev(Range("A2"), "(") > 0 Then
     品名 = Left(Mid(Range("A2"), 4, 20), InStrRev(Mid(Range("A2"), 4, 20), "(") - 1)

     Else
     MsgBox "（）を入力してください"

     Exit Sub

      End If
（UNIKO） 2025/04/18(金) 18:15:56

 検索キーから()やハイフンをとって小文字変換したものを辞書に持ち、
 同じルールに基づいて変換したが辞書にあるかを問い合わせるとよいのでは。
 先刻ご承知のことでしょうけど。

（xyz） 2025/04/18(金) 18:55:14

 > 具体的に何をどうしたいのか説明していただいた方が理解しやすいと思います。

 質問にお答え頂けないようですね...
 そのめちゃくちゃなコードをそのまま改良する気にはなれませんので私はここまでとします。
（jindon） 2025/04/18(金) 19:08:56

コメント返信：

[ 一覧(最新更新順) ]

[[20250417133308]] 『VBA 品名検索（）が含まれなくても検索したい』（UNIKO） ページの最後に飛ぶ

[[20250417133308]]　『VBA　品名検索（）が含まれなくても検索したい』（UNIKO）　ページの最後に飛ぶ