VBA InStr函數循環中的限制匹配解決方法

Question

我想弄清楚如何在動態設置中解決InStr函數的通配符解決方案。

目前我通過數據使用下面的代碼（根據下圖的示例）循環：

Sub Test() 
Dim Rng_Target As Range 
Dim Rng_Data As Range 
Dim RCntr_Target As Long 
Dim RCntr_Data As Long 
Dim Str_Tgt As String 

    Set Rng_Target = Range("E2:E3") 
    Set Rng_Data = Range("A2:C15") 

    For RCntr_Target = 0 To Rng_Target.Rows.Count 

     Str_Tgt = Rng_Target(RCntr_Target) & "High" & Rng_Target(RCntr_Target) & "Major" 

     For RCntr_Data = 0 To Rng_Data.Rows.Count 

      If InStr(1, Str_Tgt, Rng_Data(RCntr_Target, 1) & Rng_Data(RCntr_Target, 2)) > 0 Then 

       If Rng_Data(RCntr_Target, 3) < 0.9 Then 

        ' Do something 

       End If 

      End If 

     Next RCntr_Data 

    Next RCntr_Target 

End Sub 

此設置適用於9個我設置的10，但它不能處理預標籤標籤例如「Green_」。

查看下圖簡化示例圖。有沒有辦法可以跳過匹配字符串中第一個X數字（需要是動態的）字符？

---

有你需要有一點幾件事

1. 有那麼它需要是動態的5.000的行與許多不同的目標。
2. 如果列A與目標部分匹配，並且該列B爲高或主，則應包含數據。結果在目標1框和目標2框中說明。
3. 有幾十個預標籤標籤例如， 「Green_」，我不會在他們身上登記。
4. 上面有多種代碼構造，如果我需要分離InStr函數或混合更多的函數，這將是非常有問題的。

例如爲：

If InStr(1, Rng_Target(RCntr_Target), Rng_Data(RCntr_Target, 1)) > 0 Then 

    If InStr(1, "HighMajor", Rng_Data(RCntr_Target, 2)) > 0 Then 

     If Rng_Data(RCntr_Target, 3) < 0.9 Then 

      ' Do something 

     End If 

    End If 

End If 

Answer 1

我有一個很難理解你的代碼試圖完成，但我得到你所遇到的問題的要點。我試圖想出一個代碼示例（希望）能夠完成您的任務，但也會使代碼更加清晰。請看下圖：

首先，我們創建一個自定義函數返回一個清潔產品名稱：

Private Function GetProductName(ByVal InputProductName As String) As String 
    Dim ProductName As String 

    If InStr(1, InputProductName, "_") > 0 Then 
     ProductName = Split(InputProductName, "_")(1) 
    Else 
     ProductName = InputProductName 
    End If 

    GetProductName = ProductName 
End Function 

這樣做是需要一個輸入字符串，並檢查下劃線「_」。如果有下劃線，則返回輸入字符串的第二部分。如果沒有一個，它只是返回字符串本身。

然後我們日常的肉：

Sub FilterProducts() 
     Dim InputData As Variant 

     ' Point this to the range where you input data is. If only your input data is on the sheet then use the UsedRange version (for simplicity). 
     ' InputData = ThisWorkbook.Sheets("ProductInformation").UsedRange.Value 
     InputData = ThisWorkbook.Sheets("ProductInformation").Range("A1:C15").Value 

     ' To keep this dynamic I use a Scripting.Dictionary trick to dynamically find the headers I am interested in. 
     Dim HeaderIndices As Scripting.Dictionary 
     Set HeaderIndices = New Scripting.Dictionary 

     Dim i As Long 
     For i = LBound(InputData, 2) To UBound(InputData, 2) 
      ' Basically we are looping from the lowest column, to the highest column. 
      ' We then check if that header exists within the dictionary, and if it doesn't 
      ' we add the header as a key, with the index as the item. 
      If Not HeaderIndices.Exists(InputData(LBound(InputData, 1), i)) Then 
       HeaderIndices.Add InputData(LBound(InputData, 1), i), i 
      End If 
     Next 

     ' Now we will loop row-wise through the data to find the data we are interested in. 
     Dim ProductName As String 
     For i = LBound(InputData, 1) + 1 To UBound(InputData, 1) 
      ' Our row index is i (since we are looping from top to bottom) 
      ' Our column index is retrieved from the dictionary under the key of 
      ' "Fruit". You would want to change this to match the actual column name 
      ' in your input data. 
      ProductName = GetProductName(InputData(i, HeaderIndices("Fruit"))) 

      If InputData(i, HeaderIndices("Probability")) = "High" Or _ 
      InputData(i, HeaderIndices("Probability")) = "Major" Then 
       If InputData(i, HeaderIndices("Value")) < 0.9 Then 
        ' Do Something 
        ' This is where you will want to figure out your process for creating the output. 
        ' I would personally suggest learning about arrays. 
        Debug.Print "Product Name: " & ProductName & vbNewLine & vbNewLine & _ 
           "Probability: " & InputData(i, HeaderIndices("Probability")) & vbNewLine & vbNewLine & _ 
           "Value : " & InputData(i, HeaderIndices("Value")) 
       End If 
      End If 
     Next 
    End Sub 

我試圖將註釋添加到這個，使其儘可能明確。如果你想使用靜態索引（但是我建議學習更動態的方法），可以刪除其中的一些。這將採用一個輸入範圍，並循環查找「Fruit」「Probability」和「Value」的數據。然後它將匹配的產品打印到控制檯（當然，更改此部分以滿足您的需求）。

最後，爲了使用Scripting.Dictionaries，您需要Late或Early binding。我更喜歡早期綁定（使用引用），所以這裏是我用於此目的的代碼。

' You can put this in your Workbook.Open routine if you are sharing the workbook, or you can run it as a command from the immediate window. 

AddReferencebyGUID "{420B2830-E718-11CF-893D-00A0C9054228}" 

' If you do use the Workbook.Open Event, use this code: 
If CheckForAccess Then 
    RemoveBrokenReferences 
    AddReferencebyGUID "{420B2830-E718-11CF-893D-00A0C9054228}" 
End If 

Private Sub RemoveBrokenReferences() 
    ' Reference is a Variant here since it requires an external reference. 
    ' It isnt possible to ensure that the external reference is checked when this process runs. 
    Dim Reference As Variant 
    Dim i As Long 

    For i = ThisWorkbook.VBProject.References.Count To 1 Step -1 
     Set Reference = ThisWorkbook.VBProject.References.Item(i) 
     If Reference.IsBroken Then 
      ThisWorkbook.VBProject.References.Remove Reference 
     End If 
    Next i 
End Sub 

Public Function CheckForAccess() As Boolean 
    ' Checks to ensure access to the Object Model is set 
    Dim VBP As Variant 
    If Val(Application.Version) >= 10 Then 
     On Error Resume Next 
     Set VBP = ThisWorkbook.VBProject 
     If Err.Number <> 0 Then 
      MsgBox "Please pay attention to this message." _ 
       & vbCrLf & vbCrLf & "Your security settings do not allow this procedure to run." _ 
       & vbCrLf & vbCrLf & "To change your security setting:" _ 
       & vbCrLf & vbCrLf & " 1. Select File - Options - Trust Center - Trust Center Settings - Macro Settings." & vbCrLf _ 
       & " 2. Place a checkmark next to 'Trust access to the VBA project object model.'" _ 
       & vbCrLf & "Once you have completed this process, please save and reopen the workbook." _ 
       & vbCrLf & "Please reach out for assistance with this process.", _ 
        vbCritical 
      CheckForAccess = False 
      Err.Clear 
      Exit Function 
     End If 
    End If 
    CheckForAccess = True 
End Function 

引用的代碼嚴格用於綁定（這可能超出了迄今爲止學到的內容）。你可以複製和粘貼該代碼，你不應該有任何問題。我建議花更多的時間學習主程序如何工作，以便將來可以複製該過程。

如果您有任何問題，請讓我知道。