按多个关键词拆分清单？

ykcbf1100

1. Sub ykcbf()   '//2025.11.5
   
2.     Dim tm As Double
   
3.     Const bt% = 1
   
4.     Const col% = 3
   
5.     tm = Timer
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set sh = ActiveSheet
   
8.     With Application
   
9.         .ScreenUpdating = 0
   
10.         .DisplayAlerts = 0
    
11.         .Calculation = xlCalculationManual
    
12.         .AskToUpdateLinks = False
    
13.         .EnableEvents = 0
    
14.     End With
    
15.     For Each sht In Sheets
    
16.         If InStr("名称关键词|总清单", sht.Name) = 0 Then sht.Delete
    
17.     Next
    
18.     arr = sh.UsedRange.Value
    
19.     zrr = Sheets("名称关键词").UsedRange.Value
    
20.     For j = 1 To UBound(zrr, 2)
    
21.         s = Replace(zrr(1, j), "关键词", "")
    
22.         For i = 2 To UBound(zrr)
    
23.             If zrr(i, j) <> Empty Then d(s) = d(s) & "|" & zrr(i, j)
    
24.         Next
    
25.     Next
    
26.     For Each k In d.keys
    
27.         ptt = Mid(d(k), 2)
    
28.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
29.         m = 0
    
30.         For i = bt + 1 To UBound(arr)
    
31.             If styes(arr(i, col), ptt) = True Then
    
32.                 m = m + 1
    
33.                 For j = 1 To UBound(arr, 2)
    
34.                     brr(m, j) = arr(i, j)
    
35.                 Next
    
36.             End If
    
37.         Next
    
38.         sh.Copy After:=Sheets(Sheets.Count)
    
39.         With Sheets(Sheets.Count)
    
40.             .Name = k
    
41.             .DrawingObjects.Delete
    
42.             .UsedRange.Offset(bt + m).Clear
    
43.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = brr
    
44.         End With
    
45.     Next
    
46.     sh.Activate
    
47.     With Application
    
48.         .DisplayAlerts = 1
    
49.         .ScreenUpdating = 1
    
50.         .Calculation = xlCalculationAutomatic
    
51.         .AskToUpdateLinks = True
    
52.         .EnableEvents = 1
    
53.     End With
    
54.     Dim msg As String
    
55.     msg = "拆分操作完成" & vbCrLf & _
    
56.         "┌───────────────────────┐" & vbCrLf & _
    
57.         "│ 处理时间: " & Format(Timer - tm, "0.00") & "秒" & vbCrLf & _
    
58.         "│ 原始数据: " & UBound(arr) - bt & "行" & vbCrLf & _
    
59.         "│ 生成表数: " & d.Count & "个" & vbCrLf & _
    
60.         "│ 处理速度: " & Format((UBound(arr) - bt) / (Timer - tm), "0") & "行/秒" & vbCrLf & _
    
61.         "└───────────────────────┘"
    
62.     MsgBox msg, vbInformation, "执行报告"
    
63. End Sub
    
64. 
    
65. Function styes(st, ptt) As Boolean
    
66.     If Len(ptt) = 0 Or Len(st & "") = 0 Then Exit Function
    
67.     On Error Resume Next
    
68.     With CreateObject("VBScript.RegExp")
    
69.         .Pattern = ptt
    
70.         .IgnoreCase = True
    
71.         styes = .Test(CStr(st))
    
72.     End With
    
73. End Function
    

复制代码