Fatal编程技术网
  • vba/
  • Vba 在一个字符串中搜索几个精确的子字符串

Vba 在一个字符串中搜索几个精确的子字符串

vba excel search excel-formula

Vba 在一个字符串中搜索几个精确的子字符串,vba,excel,search,excel-formula,Vba,Excel,Search,Excel Formula,我有一个问题，我一直在努力一段时间，但似乎无法达到那里。我有一个大约6000个材料描述的列表，我想找出一个特定的搜索词 因此，如果描述是“Handschuhe-Wunder-20XV28”，搜索词是“Wunder”，那么该材料就会有一个新的列，上面写着“Wunder”。但是，我可能还想搜索单词“Super”，我希望它出现在同一列中 此搜索只会提取准确的单词，因此如果它正在查找“Super”，如果它找到了“Superman”，则不会返回结果 我有一个公式可以做到这一点： =IF(AQ2=1,IF(

我有一个问题，我一直在努力一段时间，但似乎无法达到那里。我有一个大约6000个材料描述的列表，我想找出一个特定的搜索词

因此，如果描述是“Handschuhe-Wunder-20XV28”，搜索词是“Wunder”，那么该材料就会有一个新的列，上面写着“Wunder”。但是，我可能还想搜索单词“Super”，我希望它出现在同一列中

此搜索只会提取准确的单词，因此如果它正在查找“Super”，如果它找到了“Superman”，则不会返回结果

我有一个公式可以做到这一点：

=IF(AQ2=1,IF(SUM(IF(ISNUMBER(SEARCH(Search!A$2, K2)), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")), (IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))<65, 1, "")), (IF((SEARCH(Search!A$2, K2)+LEN(Search!A$2)+1)>LEN(K2), 1, ""))), 1, 0), 0), 0))>0,Search!A$2,0),"")
这是为了提高效率，因为在我发布的第二个公式计算出是否值得搜索后，第一个公式分离非字母数字字符以查找准确的单词

我试着用VisualBasic记录这一点，我的想法是，作为for循环的一部分，会有更多的列，每个搜索项有两列。然后，我会以某种方式将任何搜索的结果放在一列中。然而，当我在VBA中记录长公式时，尽管包括中断，它仍然不起作用

如有任何帮助、建议或想法，我将不胜感激。很简单，它是查看一段文本，看看文本是否包含多个作品中的任何一个。它们必须是精确匹配的

谢谢大家

您仍然可以使用基于公式的方法，使用数组公式。因此，使用e1:e4中的列表和I1中的搜索条件1以及J1中的搜索条件2，我使用了以下内容

=索引（$E1:$e4），小（如果（$NOT（$ISERROR（SEARCH（$I$1&“”，$E1:$e4））+（NOT（$ISERROR（SEARCH（$J$1&“”，$E1:$e4））），行（$E1:$e4）），行（$E1:$E1））

拖下来

结果见G列

根据这些评论，我做了下面的数组公式，这一次，我把数据放在A1:A5中，搜索词放在D1和D2中

=IFERROR(INDEX($A$1:$A$5 & " (" & $D$1 &")",SMALL(IF(NOT(ISERROR(SEARCH($D$1,$A$1:$A$5))),ROW($A$1:$A$5)),ROWS($B$1:$B1))),IFERROR(INDEX($A$1:$A$5 & " (" & $D$2 &")",SMALL(IF(NOT(ISERROR(SEARCH($D$2,$A$1:$A$5))),ROW($A$1:$A$5)),ROWS($B$1:$B1)-SUM(IF(NOT(ISERROR(SEARCH($D$1,$A$1:$A$5))),1,0)))),"<>"))

=IFERROR（索引（$A$1:$A$5&“（“&$D$1&”）、SMALL（如果不是（iError）（搜索（$D$1，$A$1:$A$5））、ROW（$A$1:$A$5））、ROWS（$B$1:$B1））、IFERROR（索引（$A$1:$A$5&“（$D$D$2&$D$2&”）、SMALL（如果不是（iError）（搜索（$D$2，$A$1:$A$A$5））、ROW（$A$1））、ROW（$B$1））、SUM（如果不是搜索（$D$A$1））、ror$1））、ror$1））、ror$1、$1、$1、$1、$1、$1、$1、$A$0、$1、$1、$1）
如下所示

根据所讨论的内容，以下内容应能满足您的需求，或至少与您的想象更接近

First是一个函数，它接受您希望用以分隔字符串的所有字符：

Sub SearchDynamicDelimit()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(2)
    Dim strTest As New Collection
    Dim udRange As Range: Set udRange = ws.Range("D2", ws.Cells(ws.Rows.Count, "D").End(xlUp)) '<~~Change to your Search Range
    Dim myCell, myMatch, myString, i, delimiter, d, s, t, u, c
    Dim temp() As String, myDelimiter() As String, delNotInSearch() As String, delInSearch() As String, tempCell As String
    Dim delimitInSearch As Boolean: delimitInSearch = False
    Dim delString As String, searchString As String

    For Each myMatch In udRange
        If myMatch.Value <> "" Then strTest.Add myMatch.Value
        searchString = searchString & CStr(myMatch.Value)
        Debug.Print myMatch.Value & " " & myMatch.Address
    Next myMatch

    ws.Range("B2", ws.Cells(ws.Rows.Count, "B")).Clear '<~~Change to where you want the results to populate

    delString = "_|-|.|/|<|>|;|:|[|]|\|{|}| |(|,|)" '<~~Change to the delimiters you want. Separate them with any unique character.
    myDelimiter() = Split(delString, "|") '<~~Make sure the unique character you chose above is the same here.

    ReDim delNotInSearch(LBound(myDelimiter) To UBound(myDelimiter))
    ReDim delInSearch(LBound(myDelimiter) To UBound(myDelimiter))
    t = LBound(myDelimiter)
    u = LBound(myDelimiter)
    For s = LBound(myDelimiter) To UBound(myDelimiter)
        If InStr(searchString, myDelimiter(s)) = 0 Then
            delNotInSearch(t) = myDelimiter(s)
            Debug.Print "delNotInSearch(" & t & ") = " & delNotInSearch(t)
            t = t + 1
        Else
            delInSearch(u) = myDelimiter(s)
            Debug.Print "delInSearch(" & u & ") = " & delInSearch(u)
            u = u + 1
        End If
    Next s
    t = t - 1
    u = u - 1
    If t <> -1 Then ReDim Preserve delNotInSearch(LBound(myDelimiter) To t)
    If u <> -1 Then ReDim Preserve delInSearch(LBound(myDelimiter) To u)

    If delInSearch(LBound(delInSearch)) <> "" Then delimitInSearch = True

    If strTest.Count > 0 Then
        For Each myCell In ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp)) '<~~Change to range being searched
            If myCell.Value = "" Then GoTo SkipBlanks
                If delimitInSearch = True Then
                    temp() = MultiSplitX(myCell.Value, True, delNotInSearch())

                    For i = 0 To UBound(temp)
                        For Each myString In strTest
                            If StrComp(temp(i), myString, vbTextCompare) = 0 Then
                                If ws.Range("B" & myCell.Row).Value = "" Then   'If you only want it to show 1 search result, remove the IF statement entirely
                                    ws.Range("B" & myCell.Row).Value = temp(i)  'And keep this line only. Change "B" to where you want the results to go
                                Else: ws.Range("B" & myCell.Row).Value = ws.Range("B" & myCell.Row).Value & ", " & temp(i)
                                End If
                            End If
                        Next myString
                    Next i
                    Erase temp
                End If
                temp() = MultiSplitX(myCell.Value, True, delInSearch())
                For i = 0 To UBound(temp)
                    For Each myString In strTest
                        If StrComp(temp(i), myString, vbTextCompare) = 0 Then
                            If ws.Range("B" & myCell.Row).Value = "" Then   'If you only want it to show 1 search result, remove the IF statement entirely
                                ws.Range("B" & myCell.Row).Value = temp(i)  'And keep this line only. Change "B" to where you want the results to go
                            Else: ws.Range("B" & myCell.Row).Value = ws.Range("B" & myCell.Row).Value & ", " & temp(i)
                            End If
                        End If
                    Next myString
                Next i
                Erase temp
SkipBlanks:
        Next myCell

    Else: MsgBox "Nothing found to search...", Title:="No Search Item"
    End If
End Sub
注意：这个函数实际上有点棒

这样做的目的是找到您的搜索项目，并在新列中显示它们，以及显示找到该项目的位置

这提供了两种解决方案：

1。在VBA中使用长公式的方法

2。VBA代码可同时对所有物料描述进行分类。

1。在VBA中使用长公式的方法

这个公式对于VBA来说太长了

=IF(AQ2=1,IF(SUM(IF(ISNUMBER(SEARCH(Search!A$2, K2)), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")), (IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))<65, 1, "")), (IF((SEARCH(Search!A$2, K2)+LEN(Search!A$2)+1)>LEN(K2), 1, ""))), 1, 0), 0), 0))>0,Search!A$2,0),"")
•在找到单词前后立即验证字符：

第2部分-之前：

            IF(
                COUNT(
                    (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")),
                    (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")),
                    (IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))),
按照同样的逻辑，我修改了您的公式：

=IF(
IF(OR(
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)
<65,
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)
>122),0,1)
+
IF(OR(
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
<65,
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
>122),0,1)
<>0,"",Search!A$2)
•在以下情况后立即获取角色：

IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
现在我们使用变量来定义公式，但首先为了使公式灵活，以便可以应用于任何引用，让我们用字符串修改“硬编码”引用，这些字符串可以替换为在运行时获得的引用： 用
#Cll
和
搜索替换
$K2
！一个$2，带
#Srch

最后的代码是这样的：


Sub Vba_Long_Formula()
Dim sCll As String, sSrch As String
sCll = "$K2"
sSrch = "Search!A$2"
Dim sFmlIni As String, sFmlEnd As String    'Formulas for the before and after characters
'Chr(10) is used to ease reading by breaking the formula by line
sFmlIni = "IFERROR(CODE(TRIM(MID(#Cll,IFERROR(SEARCH(#Srch,#Cll),0)+" & Chr(10) & _
    "IF(IFERROR(SEARCH(#Srch,#Cll),0)=1,0,-1),1))),0)"
sFmlEnd = "IFERROR(CODE(TRIM(MID(#Cll,IFERROR(SEARCH(#Srch,#Cll),0)+" & Chr(10) & _
    "LEN(#Srch),1))),0)"
Dim sFml1 As String 'Formula to be applied
sFml1 = "=IF(" & Chr(10) & _
    "IF(OR(" & Chr(10) & sFmlIni & "<65," & Chr(10) & sFmlIni & ">122),0,1)+" & Chr(10) & _
    "IF(OR(" & Chr(10) & sFmlEnd & "<65," & Chr(10) & sFmlEnd & ">122),0,1)<>0,"""",#Srch)"

    sFml1 = Replace(Replace(sFml1, "#Cll", sCll), "#Srch", sSrch)
    ThisWorkbook.Sheets("Raw Data Working").Range("AR2:AR4").Formula = sFml1

    End Sub




建议阅读以下页面，以便更深入地了解所使用的资源：

,，
，

, 
, 
, 
,
, 

，
我会在VBA中执行此操作。它需要在列中循环并应用一个或多个字符串搜索函数。你能张贴你尝试的代码并解释什么不起作用吗？每个搜索词都是用破折号分隔的吗？考虑使用正则表达式…VBA总是更快。谢谢大家到目前为止对你的帮助，我必须道歉，因为我没有说清楚。并非所有单词都用“-”分隔。有些是简单的“handschuhe super 20X”，有些是“handschuhe/super:20X”，等等。基本上，每个单词之间都有空格或非字母数字字符。嗨，泰勒，谢谢你花时间这么做。但是，我无法用相同的数据集复制您的结果，我只得到您插入的错误消息。此外，虽然我可以想象这对我会有一些用处，但我注意到在你的代码中你指出了“E1”、“F1”等。因为我的问题是搜索800个项目，我无法手动扩展此位，你有什么建议吗？另外，如果它只显示它找到的单词，可能对我更有用，这样我就可以轻松地过滤结果列。谢谢你迄今为止的帮助！我不确定我是否理解你的问题是什么，当然，当我写这篇文章时，我没有看到你关于没有定界的评论。我也不认为我了解范围。你只是想看看一个搜索词出现了多少次？此外，上面的代码并不是专门针对您的需要而定制的。这就是我的想法。您必须非常详细地描述您想要的内容，或者编辑代码以满足您的需要。我无法想象这段代码只做了几个小改动就不适用于您……您还说您不能手动扩展搜索字段。为什么？你是如何得到搜索词的？它们是随机分布的吗？这有点难以描述。我有一份800个品牌的清单，和一份16000种材料描述的清单。我们希望更好地对材料进行分类，因此我们希望将品牌添加为单独的列，以便我们可以透视表等，以查看特定品牌的支出。所以无论哪个品牌是

=IF(AQ2=1,
    IF(
        SUM(
            IF(
                ISNUMBER(SEARCH(Search!A$2, K2)),



            IF(
                COUNT(
                    (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")),
                    (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")),
                    (IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))),



                IF(
                    COUNT(
                        (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))>122, 1, "")),
                        (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))<65, 1, "")),
                        (IF((SEARCH(Search!A$2, K2)+LEN(Search!A$2)+1)>LEN(K2), 1, ""))
                    ), 1, 0),
                0),
        0)
    )>0,



    Search!A$2,0)
,"")



=IF(
IF(OR(
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)
<65,
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)
>122),0,1)
+
IF(OR(
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
<65,
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
>122),0,1)
<>0,"",Search!A$2)



IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)



IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)



Sub Vba_Long_Formula()
Dim sCll As String, sSrch As String
sCll = "$K2"
sSrch = "Search!A$2"
Dim sFmlIni As String, sFmlEnd As String    'Formulas for the before and after characters
'Chr(10) is used to ease reading by breaking the formula by line
sFmlIni = "IFERROR(CODE(TRIM(MID(#Cll,IFERROR(SEARCH(#Srch,#Cll),0)+" & Chr(10) & _
    "IF(IFERROR(SEARCH(#Srch,#Cll),0)=1,0,-1),1))),0)"
sFmlEnd = "IFERROR(CODE(TRIM(MID(#Cll,IFERROR(SEARCH(#Srch,#Cll),0)+" & Chr(10) & _
    "LEN(#Srch),1))),0)"
Dim sFml1 As String 'Formula to be applied
sFml1 = "=IF(" & Chr(10) & _
    "IF(OR(" & Chr(10) & sFmlIni & "<65," & Chr(10) & sFmlIni & ">122),0,1)+" & Chr(10) & _
    "IF(OR(" & Chr(10) & sFmlEnd & "<65," & Chr(10) & sFmlEnd & ">122),0,1)<>0,"""",#Srch)"

    sFml1 = Replace(Replace(sFml1, "#Cll", sCll), "#Srch", sSrch)
    ThisWorkbook.Sheets("Raw Data Working").Range("AR2:AR4").Formula = sFml1

    End Sub



Option Compare Text     ‘Must have this at the top of the module
Option Explicit

Sub Brand_Classification()
Dim aBrands As Variant, rMaterials As Range, rResults As Range
Dim rFound As Range, blFound As Boolean, sFound As String
Dim sMaterial As String
Dim lLastRow As Long
Dim vItm As Variant
Dim iAsc As Integer, bPos As Byte
Dim b As Byte

    Rem Set Array with Brands
    With ThisWorkbook.Sheets("Search")  'Change as needed
        lLastRow = .Columns("A:A").Cells(1 + .UsedRange.SpecialCells(xlLastCell).Row).End(xlUp).Row 'Change as needed
        aBrands = .Range("A2:A" & lLastRow).Value2  'Change as needed
    End With

    With ThisWorkbook.Sheets("Raw Data Working")    'Change as needed
        Rem Set Materials Description Range
        lLastRow = .Columns("K:K").Cells(1 + .UsedRange.SpecialCells(xlLastCell).Row).End(xlUp).Row 'Change as needed
        Set rMaterials = .Range("K2:K" & lLastRow)  'Change as needed

        Rem Set Brand Results Range
        Set rResults = .Range("AP2:AP" & lLastRow)  'Change as needed
        Rem Clearing prior results
        'rResults.ClearContents     '}Choose one of
        rResults.Value = Chr(39)    '}these options

    End With

    Rem Search for Brands in Materials Description
    For Each vItm In aBrands
        If vItm <> Empty Then
            With rMaterials
                Set rFound = .Cells.Find(What:=vItm, After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

                Rem Validate Value Found
                If Not rFound Is Nothing Then
                    sFound = rFound.Address

                    Do
                        Rem Process Value Found
                        blFound = True
                        sMaterial = rFound.Value
                        For b = 1 To 2
                            Select Case b
                            Case 1
                                Rem Get Character Before Value
                                bPos = InStr(sMaterial, vItm)
                                bPos = -1 + bPos

                            Case 2
                                Rem Get Character After Value
                                bPos = InStr(sMaterial, vItm) + Len(vItm)

                            End Select

                            Rem Get Character
                            Select Case bPos
                            Case 0, Is > Len(sMaterial)
                            Case Else
                                Rem Validate Character
                                On Error Resume Next
                                iAsc = Asc(Mid(sMaterial, bPos, 1))
                                On Error GoTo 0
                                Select Case iAsc
                                Case 65 To 90, 97 To 122
                                    blFound = False

                        End Select: End Select: Next

                        Rem Write Results
                        If blFound Then
                            With rResults.Cells(1 - rMaterials.Row + rFound.Row)
                                If .Value = Empty Then
                                    .Value = vItm
                                Else
                                    .Value = .Value & ", " & vItm

                        End If: End With: End If

                        Rem Search Next
                        Set rFound = .FindNext(After:=rFound)
                        If rFound.Address = sFound Then Exit Do

    Loop: End If: End With: End If: Next

    End Sub