根据关键字拆分工作表

chqf

如附件所示，能否用VBA实现如下功能：
       根据“管征单位”列中的部分关键字比如：外税、鼓楼、闽侯、福清等（关键字位置不固定），将工作表按照该关键字拆分成新工作簿。意即根据县市级的管征单位名称拆分工作表。
跪求老师们赐教！！！！！！

LIUZHU

楼主得先明确关键字怎么获取，然后才方便按关键字查找

chxw68

1. Sub test()
   
2.   Dim reg As New RegExp
   
3.   Dim r%, i%
   
4.   Dim arr
   
5.   Dim d As New Dictionary
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   With reg
   
9.     .Global = True
   
10.     .Pattern = "外税|鼓楼|闽侯|福清|保税|音西|祥廉|融城|晋安|仓山|连江|台江"
    
11.   End With
    
12.   With Worksheets("sheet1")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     arr = .Range("a2:c" & r)
    
15.   End With
    
16.   For i = 1 To UBound(arr)
    
17.     If reg.test(arr(i, 3)) Then
    
18.       Set mh = reg.Execute(arr(i, 3))
    
19.       d(mh(0).Value) = d(mh(0).Value) & "+" & i
    
20.     End If
    
21.   Next
    
22.   For Each ws In Worksheets
    
23.     If ws.Name <> "Sheet1" Then
    
24.       ws.Delete
    
25.     End If
    
26.   Next
    
27.   For Each aa In d.Keys
    
28.     brr = Split(Mid(d(aa), 2), "+")
    
29.     ReDim crr(1 To UBound(brr) + 1, 1 To 3)
    
30.     For i = 0 To UBound(brr)
    
31.       For j = 1 To 3
    
32.         crr(i + 1, j) = arr(brr(i), j)
    
33.       Next
    
34.     Next
    
35.     Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
36.     With ws
    
37.       .Name = aa
    
38.       .Range("a1:c1") = Array("序号", "名称", "管征单位")
    
39.       .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
    
40.     End With
    
41.   Next
    
42. End Sub
    

复制代码

chxw68

如果分类不符合楼主要求，请楼主自行修改下面这句：  
.Pattern = "外税|鼓楼|闽侯|福清|保税|音西|祥廉|融城|晋安|仓山|连江|台江"

chqf

先下了，谢谢！关键字段就是县（市区）的税务机关名称，比如鼓楼、台江、闽侯、外税、直属等。因为列里是全称，我们只要取其中的关键字拆分就行。

chqf

如果想保存成新的按关键字命名的工作簿，怎么改？

chqf

还有，chxw68 老师，能否稍微解释一下？——刚接触VBA

chqf

帖子沉得太快了。自己顶顶

chxw68

chqf 发表于 2014-6-26 15:55
如果想保存成新的按关键字命名的工作簿，怎么改？

你的意思是一个关键字生成一个工作薄还是所有的工作表生成一个新的工作薄？

chqf

一个关键字生成一个工作簿。我们要便于把材料分单位下发。谢谢老师！！