根据字符串内容对组下的每个字符串进行分类（1 次）？ (Excel)

Question

复杂的问题……我先解释一下，也许有更好的解决方案而不是使用迭代计算：

(Link to Workbook)

Image showing example (to show what I'm working with)

问题：

拥有 4,000 多个字符串，并希望将它们分类为预先确定的组（基于字符串的内容）。

1. 每个字符串只能分配给一个组。 （即“55 加仑桶水龙头”将列在“水龙头”列下，因为它包含“水龙头”一词。）

2. 一旦分类到一个组中，该字符串将不会被分类到任何其他组下。 （即，“55 加仑桶形水龙头”一旦被归类为“水龙头”，就不会被归类为“桶”）。

3. 每个字符串属于哪个组并不重要，只要它被分类即可。

注意：（我几乎找到了使用迭代计算的解决方案，但不太奏效）。

解决方案：

我解决问题的方法是：

1. 使用以下公式计算字符串（A 列）在工作表中重复的次数：

    Formula: =COUNTIF($E$2:$IA$10000,A3)
   

   • 此公式位于 C 列中。

2. 创建了一个公式，该公式将根据字符串是否包含组词（即“水龙头”、“啤酒”、“加仑”、“厨房”等）对组下的字符串进行分类......并且没有以前使用过（即C列，其中包含上面的公式）。

     Formula: =IF(C3<1,IF(IFERROR(SEARCH("faucet",A3),0)>0,A3,""),"")
   

3. 向下拖动 C 列中所有 4,000 个字符串以及每个单独的“组”列的公式。

这种方法的问题在于它会进行迭代计算，这会：

1. 将字符串归为组（但不会将重复次数字段从 0 增加到 1）...

或

1. 将“重复次数”字段从 0 增加到 1，但不会将字符串归类到“组”列下。

---

对如何解决迭代计算问题有何建议？ （我知道它一直在来回计算，因为它是依赖的，所以必须解决 1 个“正确”的解决方案......我想知道是否有任何方法可以创建某种“块”，所以它只能计算一个方式...）

任何帮助将不胜感激！

Answer 1

通过您的数据运行此过程。它在一对变体数组中执行所有处理。

Sub byGroup()
    Dim g As Long, s As Long, aSTRs As Variant, aGRPs As Variant

    appTGGL bTGGL:=False

    With Worksheets("Sheet1")
        aSTRs = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value2
        With .Range(.Cells(1, 5), .Cells(Rows.Count, 1).End(xlUp).Offset(0, Application.Match("zzz", .Rows(1)) - 1))
            .Resize(.Rows.Count, .Columns.Count).Offset(1, 0).ClearContents
            aGRPs = .Cells.Value2
        End With

        For s = LBound(aSTRs, 1) To UBound(aSTRs, 1)
            For g = LBound(aGRPs, 2) To UBound(aGRPs, 2)
                If CBool(InStr(1, aSTRs(s, 1), aGRPs(1, g), vbTextCompare)) Then
                    aGRPs(s + 1, g) = aSTRs(s, 1)
                    Exit For
                End If
            Next g
        Next s

        .Cells(1, 5).Resize(UBound(aGRPs, 1), UBound(aGRPs, 2)) = aGRPs

    End With

    appTGGL
End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    Debug.Print Timer
    Application.ScreenUpdating = bTGGL
    Application.EnableEvents = bTGGL
    Application.DisplayAlerts = bTGGL
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End Sub

经过的时间（不包括您的工作表公式重新计算应在 1-2 秒范围内。

匹配组的优先级从左到右。如果您认为 “55 加仑桶” 应归为 桶 而不是 加仑，请确保桶在第 1 行中位于加仑之前。

将启用宏的新工作簿保存为 Excel 二进制工作簿 (.XLSB) 可将工作簿文件大小减少大约一半。

Answer 2

我正在做某事，而 Jeeped 打败了我。我尝试了 Jeeped 的代码，但得到了一些字符串的多个组条目。这是我正在处理的代码，如果它在这一点上有任何价值的话：

Sub sikorloa()

Dim r As Integer
Dim c As Integer
Dim LastRow As Integer
Dim LastCol As Integer
Dim strng As String
Dim grp As String

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

LastRow = Range("A" & Rows.Count).End(xlUp).Row
LastCol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column

For r = 3 To LastRow
    If Cells(r, 1).Value <> "" Then
        strng = Cells(r, 1).Value
        For c = 5 To LastCol
            grp = Cells(1, c).Value
            If InStr(strng, grp) > 0 Then
                Cells(r, c).Value = Cells(r, 1).Value
                Exit For
            End If
        Next c
    End If
Next r

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub