工作簿拆分问题（要求保留其它工作表）

Hoer · 发表于 2009-2-16 19:43

一工作簿，包含3个工作表（分别是说明表、数据表、备注表），现要求根据“数据表”中的第2列（或第3列）进行拆分若干个工作簿，并且拆分后的若干工作簿都仍然包含3个工作表（分别是说明表、数据表（数据表中的数据因拆分有所减少）、备注表），即原工作簿中除“数据表”中数据因拆分有所减少外，“说明表”和“备注表”都原封不动地分别复制到拆分后的若干工作簿中。

不知朋友们看懂了没有~

fdd · 发表于 2009-2-16 20:05

“拆分”的方法没看懂，楼主举个例吧！

Hoer · 发表于 2009-2-16 20:15

如原工作簿中根据”数据表“第2列"类别"进行拆分，将工作簿拆分成A.XLS、B.XLS、C. XLS三个工作簿。

在拆分成的三个工作簿中仍然保留原工作簿中的“说明表”和“备注表”，而"数据表"中只包含类别为A（或为B或为C）的相关记录。

fdd · 发表于 2009-2-16 21:33

Sub addWK()
Dim dic, temp, arr, tempWK, temp2
Dim rng As Range
Set dic = CreateObject("scripting.dictionary")
Set rng = ThisWorkbook.Sheets("数据表").Range("b2:b" & ThisWorkbook.Sheets("数据表").Cells(65536, 2).End(xlUp).Row)
For Each temp In rng.Cells
If Not dic.exists(temp.Value) Then
      dic.Add temp.Value, ""
End If
Next
arr = dic.keys
For Each temp In arr
ThisWorkbook.Sheets(Array("说明表", "数据表", "备注表")).Select
ActiveSheet.Cells.Copy
Set tempWK = Workbooks.Add
tempWK.ActiveSheet.Cells.PasteSpecial
tempWK.Sheets(1).Name = "说明表"
tempWK.Sheets(2).Name = "数据表"
tempWK.Sheets(3).Name = "备注表"
tempWK.Sheets("数据表").Activate
tempWK.Sheets("数据表").Cells.Clear

For Each temp2 In rng
      If temp2 = temp Then
         temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy tempWK.Sheets("数据表").Cells(tempWK.Sheets("数据表").Cells(65536, 2).End(xlUp).Row + 1, 1)

      End If
Next
ThisWorkbook.Sheets("数据表").Range("1:1").Copy tempWK.Sheets("数据表").Range("1:1")
tempWK.SaveAs ThisWorkbook.Path & "\" & temp
tempWK.Close True
Next
Set dic = Nothing
Set rng = Nothing
ThisWorkbook.Sheets(1).Select

End Sub

[ 本帖最后由 fdd 于 2009-2-16 21:53 编辑 ]

Hoer · 发表于 2009-2-16 21:45

谢谢fdd，经测试可以运行。

不过这儿我只是举了个例子，如果原工作簿中除拆分工作表外的其它工作表（个数和名称）不确定，不知能否修改得通用一些。

呵呵，要求有点高，上面的程序也够我研究半天的了。

我根据以前某个高手的代码稍做修改，思路有点乱，但经测试也行，烦请朋友们批评指正。
Sub chaifen()
Dim clm_d As Integer
Dim sh As Worksheet
Dim mycell As Range
Dim Nodupes As New Collection
Dim rngOp As Range

Set shtop = ActiveSheet

clm_d = Application.InputBox(prompt:="请选择作为拆分条件的列" _
& Chr(13) & "注意：" & Chr(13) & "1、拆分区域需要有标题行！" & Chr(13) & "2、直接 _输入列号，不要用鼠标选取", Type:=1)

      If clm_d = False Then Exit Sub
      On Error Resume Next

For Each mycell In shtop.Range(Cells(2, clm_d), (shtop.Cells(2, clm_d).End(xlDown)))
      Nodupes.Add mycell.Value, CStr(mycell.Value)
Next mycell
On Error GoTo 0

Application.ScreenUpdating = False

Set rngOp = Cells.CurrentRegion

For Each Item In Nodupes

Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Item
      rngOp.AutoFilter clm_d, Criteria1:=Item
      rngOp.Copy
      Workbooks(Workbooks.Count).Activate
      ActiveSheet.Paste
      ActiveSheet.Name = shtop.Name

Workbooks("例子.xls").Activate
Sheets("说明表").Select
Sheets("说明表").Copy Before:=Workbooks(Item & ".xls").Sheets(shtop.Name)
Workbooks("例子.xls").Activate
Sheets("备注表").Select
Sheets("备注表").Copy after:=Workbooks(Item & ".xls").Sheets(shtop.Name)

'==使用For Each...Next语句遍历工作簿中所有的工作表，将工作簿中凡是以“Sheet”开头的工作表删除===
Application.DisplayAlerts = False
For Each sh In Worksheets
      If sh.Name Like "Sheet*" Then sh.Delete
Next
   Application.DisplayAlerts = True


      Workbooks(Workbooks.Count).Close True
Next Item

rngOp.AutoFilter
shtop.Activate

Application.ScreenUpdating = True

End Sub

fdd · 发表于 2009-2-16 22:14

下面的代码只需设置：拆分依据表的名称及根据该表的第几列拆分工作簿即可。

Option Explicit
Sub addWK()
Dim dic, temp, arr, arrSh(), tempWK, temp2, i As Long
Dim rng As Range
Const BYSHNAME As String = "数据表"
Set dic = CreateObject("scripting.dictionary")
Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("b2:b" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
For Each temp In rng.Cells
If Not dic.exists(temp.Value) Then
dic.Add temp.Value, ""
End If
Next
arr = dic.keys
ReDim arrSh(1 To ThisWorkbook.Sheets.Count)
For Each temp In Sheets
i = i + 1
arrSh(i) = temp.Name
Next
For Each temp In arr
ThisWorkbook.Sheets(arrSh).Select
ActiveSheet.Cells.Copy
Set tempWK = Workbooks.Add
tempWK.ActiveSheet.Cells.PasteSpecial
For i = 1 To ThisWorkbook.Sheets.Count
tempWK.Sheets(i).Name = ThisWorkbook.Sheets(i).Name
Next
tempWK.Sheets(BYSHNAME).Activate
tempWK.Sheets(BYSHNAME).Cells.Clear
For Each temp2 In rng
If temp2 = temp Then
temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)
End If
Next
ThisWorkbook.Sheets(BYSHNAME).Range("1:1").Copy tempWK.Sheets(BYSHNAME).Range("1:1")
tempWK.SaveAs ThisWorkbook.Path & "" & temp
tempWK.Close True
Next
Set dic = Nothing
Set rng = Nothing
ThisWorkbook.Sheets(1).Select
End Sub

复制代码

Hoer · 发表于 2009-2-17 06:40

呵呵，差不多了，不过因为我对VBA的了解还比较肤浅，看了半天没看出个大概来，能不能再次麻烦fdd对上面这段代码做一个思路介绍及语句解释，帮助我理解上面这段代码，以便更好的利用代码。

在学习excel的路上有贵人指点，我真的不胜感激。

ps:经测试，对代码稍作修改，基本成完成预定目标。

但还有如下问题：
1、如果源工作簿有代码和窗体存在，折分后的工作簿中不会把代码也拷贝或窗体复制进来。
2、如果源工作簿有名称定义，折分后工作的名称会链接到源工作簿。
2、如果折分列数据量很大的话，用这段代码速度过慢。

[ 本帖最后由 Hoer 于 2009-2-17 08:45 编辑 ]

fdd · 发表于 2009-2-17 09:44

原帖由 Hoer 于 2009-2-17 06:40 发表
呵呵，差不多了，不过因为我对VBA的了解还比较肤浅，看了半天没看出个大概来，能不能再次麻烦fdd对上面这段代码做一个思路介绍及语句解释，帮助我理解上面这段代码，以便更好的利用代码。

在学习excel的路上有贵人 ...

下面的代码解决了复制的内容缺失的问题。至于速度问题，我到现在为止没有找到更好的办法。

Option Explicit
Sub addWK2()
Dim dic, temp, arr, tempWK, temp2
Dim rng As Range
Const BYSHNAME As String = "数据表" '可以修改根据哪一个工作表拆分工作簿
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary") '字典
'下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("b2:b" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
If Not dic.exists(temp.Value) Then
dic.Add temp.Value, ""
End If
Next
arr = dic.keys '返回此列不重复值的数组
For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并复制应有的内容
ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "" & temp & ".xls" '以当前temp的值为新工作簿的名称，备份当前工作簿
Set tempWK = Workbooks.Open(ThisWorkbook.Path & "" & temp & ".xls") '打开以temp的值为名称的工作簿
tempWK.Sheets(BYSHNAME).Cells.Clear '清除该工作簿以BYSHNAME为名称的工作表的所有内容
For Each temp2 In rng '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，相同即复制相关内容
If temp2 = temp Then
'下面代码：temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy是复制源工作表的从A-D列的内容
'代码tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)是获取tempWK工作簿以BYSHNAME为名称的工作表的最后列的下一行第一列的位置
temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)
End If
Next
ThisWorkbook.Sheets(BYSHNAME).Range("1:1").Copy tempWK.Sheets(BYSHNAME).Range("1:1") '复制标题栏
tempWK.Save
tempWK.Close
Next
Application.ScreenUpdating = True
Set dic = Nothing
Set rng = Nothing
ThisWorkbook.Sheets(1).Select
End Sub

复制代码

[ 本帖最后由 fdd 于 2009-2-17 10:06 编辑 ]

Hoer · 发表于 2009-2-17 10:10

速度的话我修改了一下代码，即拷贝好工作表，然用筛选后再删除的办法比较快~~
tempWK.Sheets(BYSHNAME).Activate
Rows(1).Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="<>" & temp, Operator:=xlAnd

j = tempWK.Sheets(BYSHNAME).Range("E65536").End(xlUp).Row

Application.DisplayAlerts = False

tempWK.Sheets(BYSHNAME).Rows("2:" & j).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
Selection.AutoFilter

现在的问题是如果源工作簿中有名称定义，拆分成新的工作簿中的名称的链接会链接到源工作簿中；还有一个问题是不能把源工作表中存在的代码存复制到折分后的工作簿中去。

[ 本帖最后由 Hoer 于 2009-2-17 10:15 编辑 ]

fdd · 发表于 2009-2-17 10:13

原帖由 Hoer 于 2009-2-17 10:10 发表
速度的话我修改了一下代码，即拷贝好工作后用先筛选再删除的办法比较快~~
tempWK.Sheets(BYSHNAME).Activate
Rows(1).Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:=" ...

链接的问题是您的函数或代码本身的问题。程序还不可能智能到去判断函数或代码内容并根据此内容去做相应的改变！

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

[求助] 工作簿拆分问题（要求保留其它工作表）

最新热点 /1