根据string内容对组（1次）下的每个string进行分类？ （EXCEL）

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

（链接到工作簿）

显示示例的图片（以显示我正在处理的内容）

问题：

有4000多个string，并希望将它们分类为预定的组（基于string的内容）。

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

2. 一旦分类到组中，该string将不会被分类到任何其他组下。 （即“55加仑桶装水龙头”一旦归入“水龙头”，将不会被归入“桶装”类别）。

3. 只要对它进行分类，每个string所属的组是完全没有关系的。

注意：（我几乎find了一个使用迭代计算的解决scheme，但是这不太合适）。

解：

我解决这个问题的方法是：

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

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

   • 这个公式在C列

2. 创build一个公式，根据该string是否包含组字（即“龙头”，“啤酒”，“加仑”，“厨房”等），将一个string分类在一个组下面，并且之前没有使用（即C列，其中包含上面的公式）。

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

3. 将列C中所有4,000个string以及每个“组”列的公式向下拖动。

这种方法的问题是它会做一个迭代计算：

1. 分组下的string（但不会将时间副本字段从0增加到1）…

要么

2. 将“Times Dup'd”字段从0增加到1，但将保持string不被分组在“列”列下。

---

有关如何解决迭代计算问题的任何build议？ （我知道它不断来回计算，因为它是依赖的，所以将不得不解决与1“正确的”解决scheme…我想知道是否有任何方式来创build某种'块'，所以它只能计算一个办法…）

任何帮助将不胜感激！

Answer 1

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

 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加仑的鼓'应该被归类为鼓而不是加仑，那么确保鼓在第一排加仑之前。

将新的启用macros的工作簿另存为Excel二进制工作簿（.XLSB）将工作簿文件大小减less大约一半。

Answer 2

我正在做一些事情，Jeeped殴打我的答案。 我尝试了Jeeped的代码，但得到了一些string的多个组条目。 这里是我正在处理的代码，如果它在这一点上有任何价值：

 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