以下可能有帮助的原始答案

Question

我有一个问题，我已经工作了一段时间，但似乎无法到达那里。我有一个大约6000个材料描述的列表，我想提取一个特定的搜索单词。

因此，如果描述是＆＃39; Handschuhe-Wunder-20XV28＆＃39;并且搜索词是＆＃39; Wunder＆＃39;那么这个材料将会有一个新列，表示＆＃39; Wunder＆＃39 ;.但是，我可能还想搜索“超级＆＃39;”这个词，我希望它出现在同一列中。

此搜索只会获取确切的字词，因此如果它正在寻找超级＆＃39;如果它找到“超人”这个词，它就不会返回结果。

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

=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),"")

AQ2包含初始快速搜索：

=IF(IFERROR(SEARCH(Search!$A$2,'Raw Data Working'!K2),0)=0,"",1)

这是为了提高效率，因为第一个公式将非字母数字字符分开以找到确切的单词，在我发布的第二个公式之后确定是否值得搜索。

我尝试在visual basic中录制它，并认为作为for循环的一部分会有列增加，每个搜索项有两列。然后，我会以某种方式将任何搜索结果带入一列。但是，当我在VBA中记录长公式时，尽管包括中断，它仍然不起作用。

对于任何帮助，建议或想法，我将不胜感激。很简单，它正在查看一段文本，以查看文本是否包含多个作品中的任何一个。而且他们必须完全匹配。

谢谢大家！

Answer 1

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

=INDEX($E$1:$E$4,SMALL(IF((NOT(ISERROR(SEARCH($I$1 & " ",$E$1:$E$4))))+(NOT(ISERROR(SEARCH($J$1 & " ",$E$1:$E$4)))),ROW($E$1:$E$4)),ROWS($E$1:$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)))),"<>"))

这看起来如下

Answer 2

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

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

注意：这个功能实际上很棒。

Function MultiSplitX(ByVal SourceText As String, RemoveBlankItems As Boolean, ParamArray Delimiters()) As String()
    Dim a As Integer, b As Integer, n As Integer
    Dim i As Integer: i = 33
    Dim u As Variant, v As Variant
    Dim tempArr() As String, finalArr() As String, fDelimiters() As String

    If InStr(TypeName(Delimiters(0)), "()") <> 0 And LBound(Delimiters) = UBound(Delimiters) Then
        ReDim fDelimiters(LBound(Delimiters(0)) To UBound(Delimiters(0))) 'If passing array vs array items then
        For a = LBound(Delimiters(0)) To UBound(Delimiters(0))            'build that array
            fDelimiters(a) = Delimiters(0)(a)
        Next a
    Else
        fDelimiters = Delimiters(0)
    End If

    Do While InStr(SourceText, Chr(i)) <> 0 'Find an unused character
        i = i + 1
    Loop

    For a = LBound(fDelimiters) To UBound(fDelimiters) 'Sort Delimiters by length
        For b = a + 1 To UBound(fDelimiters)
            If Len(fDelimiters(a)) < Len(fDelimiters(b)) Then
                u = fDelimiters(b)
                fDelimiters(b) = fDelimiters(a)
                fDelimiters(a) = u
            End If
        Next b
    Next a

    For Each v In fDelimiters 'Replace Delimiters with a common character
        SourceText = Replace(SourceText, v, Chr(i))
    Next

    tempArr() = Split(SourceText, Chr(i)) 'Remove empty array items
    If RemoveBlankItems = True Then
        ReDim finalArr(LBound(tempArr) To UBound(tempArr))
        n = LBound(tempArr)
        For i = LBound(tempArr) To UBound(tempArr)
            If tempArr(i) <> "" Then
                finalArr(n) = tempArr(i)
                n = n + 1
            End If
        Next i
        n = n - 1
        ReDim Preserve finalArr(LBound(tempArr) To n)

        MultiSplitX = finalArr
    Else: MultiSplitX = tempArr
    End If
    Erase finalArr
    Erase tempArr
End Function

接下来是查找所有适用匹配项的例程：

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

在我的示例工作簿中，我使用例程结合MultiSplit函数得出以下结果：

通知Sich.Okay已正确找到，即使"."被用作分隔符。

+++++++++++++++++++++++++++++++++++++++++++++++ ++++++++++++++++++++++++++

以下可能有帮助的原始答案

如果你想要一个使用VBA的方法，你可以试试这样的东西：

Sub ColorMatchingString()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
    Dim strTest As Collection: Set strTest = New Collection
    Dim udRange As Range: Set udRange = ws.Range("E1:G1") 'Define Search Ranges
    Dim myCell, myMatch, myString, i, nextRR As Long
    Dim temp() As String, tempLength As Integer, stringLength As Integer

    nextRR = 3

    For Each myMatch In udRange 'Build the collection with Search Range Values
        strTest.Add myMatch.Value
    Next myMatch
    If ws.Range("E1").Value <> "" Or ws.Range("F1").Value <> "" Or ws.Range("G1").Value <> "" Then
        For Each myCell In ws.Range("A1:A50")
            temp() = Split(myCell.Text, "-")
            startLength = 0
            stringLength = 0
            For i = 0 To UBound(temp)
                tempLength = Len(temp(i))
                stringLength = stringLength + tempLength + 2
                For Each myString In strTest
                    If StrComp(temp(i), myString, vbTextCompare) = 0 Then
                        ws.Range("H" & nextRR).Value = myCell.Text
                        ws.Range("I" & nextRR).Value = myCell.Address
                        startLength = stringLength - tempLength - 2
                        ws.Range("H" & nextRR).Characters(startLength, tempLength).Font.Color = vbRed
                        nextRR = nextRR + 1
                    End If
                Next myString
            Next i
            Erase temp
        Next myCell
    Else: MsgBox "Nothing found to search...", Title:="No Search Item"
    End If
End Sub

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

Answer 3

目前有两种解决方案：

<强> 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),"")

要使用VBA编写长公式，我们需要使用变量将其分成几个部分。因此，让我们首先看看由excel函数细分的公式：

=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)
    ,"")

这个公式基本上有4个部分：

•它会检查您在单元格AQ2 - 第1部分

中所谓的快速搜索

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

•在找到的单词之前和之后立即验证字符：

第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, ""))),

第3部分 - 之后：

                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,

•然后返回结果 - 第4部分

    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)

现在我们使用变量来定义公式，但首先为了使公式具有灵活性，以便可以应用任何引用，让我们用可以替换的字符串修改“硬编码”引用使用在运行时获得的引用：将$K2替换为#Cll，将Search!A$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中长公式的问题。

<强> 2。 VBA代码一次性对所有材料描述进行分类。

但是，如果您使用的是VBA，则使用VBA运行整个流程以使用相应的品牌对所有材料描述进行分类会更有效。

此代码假定以下（根据需要更改）：

品牌列表从'Search'!A2

开始

材料清单说明从'Raw Data Working'!K2

开始

专栏'Raw Data Working'!AP

中的品牌输出

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

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

Do...Loop Statement， For Each...Next Statement，
On Error Statement， Option keyword， Range Object (Excel)， Select Case Statement， Variables & Constants， With Statement，

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

3 个答案:

以下可能有帮助的原始答案