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 

引用的代码严格用于绑定（这可能超出了迄今为止学到的内容）。你可以复制和粘贴该代码，你不应该有任何问题。我建议花更多的时间学习主程序如何工作，以便将来可以复制该过程。

如果您有任何问题，请让我知道。