一点小小的代码

Sub XXX_精确分组()
Dim t As Single                               '统计代码运行时间
t = Timer

Dim a, b, c, h, i, jj, k As Integer
Range("A3:A65536").Font.ColorIndex = 0         '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV65536").ClearContents              '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
a = [a65536].End(3).Row                        '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column                 '获取第二行，词根行的总个数
c = 0                                          '获取分组的关键词总个数
    
Cells(1, 1) = "如有好的建议或意见可+Q交流:85899727, 注明理由"

For i = 3 To b
    h = 0
    k = 3
    
    For jj = 3 To a
    
    If Cells(jj, 1).Font.ColorIndex <> 15 Then  '未分组的词，无颜色，即进行分组
    
    arr = Split(Cells(2, i), "+")
    x = Int(UBound(arr) + 1)
    If x > 4 Then
              MsgBox "对不起，为减少计算占用内存程序暂时只支持最多4个词根的完全存在的组合，请检查词根是否有大于3个“+”", 48, "问题提示"
          Exit Sub
    End If
    
    
    If x = 1 Then
      
       If Cells(jj, 1) Like "*" & Cells(2, i) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
       End If
      
    ElseIf x > 1 Then

      Select Case x
      
      Case 2
        If Cells(jj, 1) Like "*" & arr(0) & "*" And Cells(jj, 1) Like "*" & arr(1) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
        End If
      
      Case 3
        If Cells(jj, 1) Like "*" & arr(0) & "*" And Cells(jj, 1) Like "*" & arr(1) & "*" And Cells(jj, 1) Like "*" & arr(2) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
        End If
      
      Case 4
        If Cells(jj, 1) Like "*" & arr(0) & "*" And Cells(jj, 1) Like "*" & arr(1) & "*" And Cells(jj, 1) Like "*" & arr(2) & "*" And Cells(jj, 1) Like "*" & arr(3) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
        End If

      End Select
      
    End If
    End If
    Next jj
    
    If k = 3 Then
     l = "暂无"
     Cells(h + 3, i) = l
     Cells(h + 3, i).Font.ColorIndex = 5
    End If
Next i

'统计分组个数
s = "待分关键词" & a - 2 & "个" & vbCrLf & "已成功分组" & c & "个" & vbCrLf & "未完成分组" & a - c - 2 & "个"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 9
 
 Call BB
 Range("e" & 1) = Timer - t
End Sub

Sub XXX_模糊分组()
Dim a, b, c, h, i, jj, k As Integer
Range("A3:A65536").Font.ColorIndex = 0         '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV65536").ClearContents              '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
a = [a65536].End(3).Row                        '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column                 '获取第二行，词根行的总个数
c = 0                                          '获取分组的关键词总个数
    
Cells(1, 1) = "如有好的建议或意见可+Q交流:85899727, 注明理由"

For i = 3 To b
    h = 0
    k = 3
    
    For jj = 3 To a
    
    arr = Split(Cells(2, i), "&")
    x = Int(UBound(arr) + 1)
    If x > 4 Then
              MsgBox "对不起，为减少计算占用内存程序暂时只支持最多4个词根的完全存在的组合，请检查词根是否有大于3个“+”", 48, "问题提示"
          Exit Sub
    End If
    
    
    If x = 1 And Cells(jj, 1).Font.ColorIndex <> 15 Then
      
       If Cells(jj, 1) Like "*" & Cells(2, i) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
       End If
      
    ElseIf x > 1 And Cells(jj, 1).Font.ColorIndex <> 15 Then

      Select Case x
      Case 2
        If Cells(jj, 1) Like "*" & arr(0) & "*" Or Cells(jj, 1) Like "*" & arr(1) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
        End If
      
      Case 3
        If Cells(jj, 1) Like "*" & arr(0) & "*" Or Cells(jj, 1) Like "*" & arr(1) & "*" Or Cells(jj, 1) Like "*" & arr(2) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
        End If
      
      Case 4
        If Cells(jj, 1) Like "*" & arr(0) & "*" Or Cells(jj, 1) Like "*" & arr(1) & "*" Or Cells(jj, 1) Like "*" & arr(2) & "*" Or Cells(jj, 1) Like "*" & arr(3) & "*" Then
           Cells(k, i) = Cells(jj, 1)
           Range("A" & jj).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
        End If

      End Select
      
    End If
     
    Next jj
    
    If k = 3 Then
     l = "暂无"
     Cells(h + 3, i) = l
     Cells(h + 3, i).Font.ColorIndex = 5
    End If
Next i

'统计分组个数
s = "待分关键词" & a - 2 & "个" & vbCrLf & "已成功分组" & c & "个" & vbCrLf & "未完成分组" & a - c - 2 & "个"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 9
 
 Call BB
 
End Sub

Sub XXX()
Dim a, b, c, h, i, j, k As Integer
Range("A3:A65536").Font.ColorIndex = 0         '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV65536").ClearContents              '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
a = [a65536].End(3).Row                        '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column                 '获取第二行，词根行的总个数
c = 0                                          '获取分组的关键词总个数
For i = 3 To b
    h = 0
    k = 3
    For j = 3 To a
        If Cells(j, 1) Like "*" & Cells(2, i) & "*" And Cells(j, 1).Font.ColorIndex <> 15 Then
           Cells(k, i) = Cells(j, 1)
           Range("A" & j).Font.ColorIndex = 15
           k = k + 1
           c = c + 1
        End If
    Next j
    If k = 2 Then
     l = "暂无"
     Cells(h + 2, i) = l
     Cells(h + 2, i).Font.ColorIndex = 5
  '  Else
  '    h = k - 1
  '    l = "共有" & (k - 2) & "个关键词"
  '    Cells(h + 2, i) = l
  '    Cells(h + 2, i).Font.ColorIndex = 3
    End If
Next i

'统计分组个数
s = "待分关键词" & a - 2 & "个" & vbCrLf & "已成功分组" & c & "个" & vbCrLf & "未完成分组" & a - c - 2 & "个"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 9
 Call BB
End Sub

Sub BB()  '作用是获取未分组的关键词，并显示到第二列
Dim a, i, k As Integer
a = [a65536].End(3).Row
k = 3
For i = 3 To a
    If Range("A" & i).Font.ColorIndex <> 15 Then
       Range("B" & k) = Range("A" & i)
       k = k + 1
    End If
Next i
End Sub

Sub clear()  '清空内容并还原颜色
a = [a65536].End(3).Row
Range("B3:IV65536").ClearContents
Range("A3:IV65536").Font.ColorIndex = 1
s = "待分关键词" & a - 2 & "个" & vbCrLf & "已成功分组0个" & vbCrLf & "未完成分组" & a - 2 & "个"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 9
End Sub

Sub clear_one()  '清空首列内容并还原颜色

 If MsgBox("你确定要清除【首列待分的所有关键词】？清除后，该操作不可撤销还原，慎用！", vbYesNo, "Joy 对清除功能 友情提示！") = vbYes Then
    Range("A3:A65536").ClearContents
    Range("A3:IV65536").Font.ColorIndex = 1
    s = "首列待分关键词" & vbCrLf & "已清空！"
    Range("C" & 1) = s
    Range("C" & 1).Font.Size = 12
End If

End Sub

Sub Keyword_consumption()
Dim a, b, c, h, i, jj, k As Integer

Range("A3:A65536").Font.ColorIndex = 0         '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV65536").ClearContents              '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
a = [a65536].End(3).Row                        '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column                 '获取第二行，词根行的总个数
c = 0                                          '获取分组的关键词总个数

End Sub