根据关键字拆分工作表

chxw68 · 发表于 2014-6-26 16:24

Sub test()
Dim reg As New RegExp
Dim r%, i%
Dim arr
Dim d As New Dictionary
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
With reg
.Global = True
.Pattern = "外税|鼓楼|闽侯|福清|保税|音西|祥廉|融城|晋安|仓山|连江|台江"
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:c" & r)
End With
For i = 1 To UBound(arr)
If reg.test(arr(i, 3)) Then
Set mh = reg.Execute(arr(i, 3))
d(mh(0).Value) = d(mh(0).Value) & "+" & i
End If
Next
For Each ws In Worksheets
If ws.Name <> "Sheet1" Then
ws.Delete
End If
Next
For Each aa In d.Keys
brr = Split(Mid(d(aa), 2), "+")
ReDim crr(1 To UBound(brr) + 1, 1 To 3)
For i = 0 To UBound(brr)
For j = 1 To 3
crr(i + 1, j) = arr(brr(i), j)
Next
Next
Set wb = Workbooks.Add
With wb
With .Worksheets(1)
.Range("a1:c1") = Array("序号", "名称", "管征单位")
.Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
End With
.SaveAs Filename:=ThisWorkbook.Path & "" & aa & ".xls"
.Close
End With
Next
' Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
' With ws
' .Name = aa
' .Range("a1:c1") = Array("序号", "名称", "管征单位")
' .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
' End With
End Sub

复制代码

chxw68 · 发表于 2014-6-26 16:26

生成的新工作薄与本工作薄在一个文件夹下。

chqf · 发表于 2014-6-26 16:48

谢谢chxw68 老师

chqf · 发表于 2014-6-26 17:18

你好！chxw68 老师，感谢您的代码，基本符合我的要求。几个疑问，麻烦您帮忙一下：
1、复制您的代码时，为什么会提示“用户定义类型未定义”
2、.Pattern = "外税|鼓楼|闽侯|福清|保税|音西|祥廉|融城|晋安|仓山|连江|台江"，执行时，为什么比如音西、融城这样关键字的记录无法分拆？
还有一个问题，就是每个工作表列字段数不固定，有点不止3列，能否在拆分时做到：直接根据表头生成新的工作簿，而不是把每个列字段写入新的工作簿

chqf · 发表于 2014-6-26 17:25

还有一个请求，能否稍微解释一下代码？

chxw68 · 发表于 2014-6-26 17:25

Sub test()
Dim reg As Object
Dim r%, i%
Dim arr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
With reg
.Global = True
.Pattern = "外税|鼓楼|闽侯|保税|音西|祥廉|融城|晋安|仓山|连江|台江"
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:c" & r)
End With
For i = 1 To UBound(arr)
If reg.test(arr(i, 3)) Then
Set mh = reg.Execute(arr(i, 3))
d(mh(0).Value) = d(mh(0).Value) & "+" & i
End If
Next
For Each ws In Worksheets
If ws.Name <> "Sheet1" Then
ws.Delete
End If
Next
For Each aa In d.Keys
brr = Split(Mid(d(aa), 2), "+")
ReDim crr(1 To UBound(brr) + 1, 1 To 3)
For i = 0 To UBound(brr)
For j = 1 To 3
crr(i + 1, j) = arr(brr(i), j)
Next
Next
Set wb = Workbooks.Add
With wb
With .Worksheets(1)
.Range("a1:c1") = Array("序号", "名称", "管征单位")
.Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
End With
.SaveAs Filename:=ThisWorkbook.Path & "" & aa & ".xls"
.Close
End With
' Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
' With ws
' .Name = aa
' .Range("a1:c1") = Array("序号", "名称", "管征单位")
' .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
' End With
Next
End Sub

复制代码

chxw68 · 发表于 2014-6-26 17:29

第1个问题：通过后期绑定控件的方式已解决。
第2个问题：音西和融城都在福清局下面，所以这两个都分离到福清这个工作薄里了，把.Pattern中的“福清”删掉就好了。
第3个问题：这段代码是针对你这个问题量身定做的，不是通用程序。

chqf · 发表于 2014-6-26 17:35

谢谢！明白了

chqf · 发表于 2014-6-26 17:42

如果有不同结构的工作表，拆分时是不是只要改这几个地方？
.Pattern = "外税|鼓楼|闽侯|保税|音西|祥廉|融城|晋安|仓山|连江|台江"

Set mh = reg.Execute(arr(i, 3))（3是不是指关键字所在的第三列？）

.Range("a1:c1") = Array("序号", "名称", "管征单位")

.Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr

chxw68 · 发表于 2014-6-26 17:51

chqf 发表于 2014-6-26 17:42
如果有不同结构的工作表，拆分时是不是只要改这几个地方？
.Pattern = "外税|鼓楼|闽侯|保税|音西|祥廉|融 ...

是这样的。

		自动登录	找回密码
密码			免费注册

[求助] 根据关键字拆分工作表