根据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)…

要么

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

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

任何帮助将不胜感激!

通过您的数据运行此过程。 它执行一对变体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大约一半。

我正在做一些事情,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