如何用VBA将下述每行中对应文本数据进行分类筛选并提取出来

mai51

详细如下图示例：

山菊花

供参考。

mai51

山菊花 发表于 2024-2-12 08:28
供参考。

老师，不好意思，最后那一类我没有解释清楚，如下图，E类之所以是空白我想表达的是剩余文本的意思，即B列每行文本中将A类、B类、C类、D类全部提取完了后，将B列文本的剩余概念词全部一并提取出来，能不能再完善一下，谢谢。

山菊花

mai51 发表于 2024-2-12 09:04
老师，不好意思，最后那一类我没有解释清楚，如下图，E类之所以是空白我想表达的是剩余文本的意思，即B列 ...

楼上附件已更新。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, dr, i&, j&, k&, dic(1) As New Dictionary
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    br = [J1:N1000].Value
    ReDim cr(1 To UBound(ar), 1 To UBound(br, 2) + 1)
    cr(1, 1) = "编码"
    For j = 1 To UBound(br, 2)
        cr(1, j + 1) = br(1, j)
    Next j
   
    For i = 2 To UBound(ar)
        cr(i, 1) = ar(i, 1)
        dr = Split(ar(i, 2), ",")
        dic(0).RemoveAll
        For j = 0 To UBound(dr): dic(0)(dr(j)) = Empty: Next
        For j = 1 To UBound(br, 2) - 1
            dic(1).RemoveAll
            For k = 2 To UBound(br)
                If Len(br(k, j)) Then
                     If dic(0).exists(br(k, j)) Then
                          dic(1)(br(k, j)) = Empty
                          dic(0).Remove br(k, j)
                     End If
                End If
            Next k
            If dic(1).Count > 0 Then cr(i, j + 1) = Join(dic(1).keys, ",")
        Next j
        If dic(0).Count > 0 Then cr(i, UBound(cr, 2)) = Join(dic(0).keys, ",")
    Next i
   
    [P1].CurrentRegion.ClearContents
    [P1].Resize(UBound(cr), UBound(cr, 2)) = cr
    Erase dic
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。