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

Hoer

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

不知朋友们看懂了没有~

fdd

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

Hoer

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

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

fdd

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

谢谢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

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

1. Option Explicit
   
2. 
   
3. Sub addWK()
   
4. Dim dic, temp, arr, arrSh(), tempWK, temp2, i As Long
   
5. Dim rng As Range
   
6. Const BYSHNAME As String = "数据表"
   
7. 
   
8. Set dic = CreateObject("scripting.dictionary")
   
9. Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("b2:b" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
   
10. For Each temp In rng.Cells
    
11.     If Not dic.exists(temp.Value) Then
    
12.         dic.Add temp.Value, ""
    
13.     End If
    
14. Next
    
15. 
    
16. arr = dic.keys
    
17. ReDim arrSh(1 To ThisWorkbook.Sheets.Count)
    
18. 
    
19. For Each temp In Sheets
    
20.     i = i + 1
    
21.     arrSh(i) = temp.Name
    
22. Next
    
23. For Each temp In arr
    
24.     ThisWorkbook.Sheets(arrSh).Select
    
25.     ActiveSheet.Cells.Copy
    
26.     Set tempWK = Workbooks.Add
    
27.     tempWK.ActiveSheet.Cells.PasteSpecial
    
28.     For i = 1 To ThisWorkbook.Sheets.Count
    
29.    
    
30.         tempWK.Sheets(i).Name = ThisWorkbook.Sheets(i).Name
    
31.         
    
32.         
    
33.     Next
    
34.         tempWK.Sheets(BYSHNAME).Activate
    
35.         tempWK.Sheets(BYSHNAME).Cells.Clear
    
36.    
    
37.     For Each temp2 In rng
    
38.         If temp2 = temp Then
    
39.             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)
    
40.             
    
41.         End If
    
42.     Next
    
43.     ThisWorkbook.Sheets(BYSHNAME).Range("1:1").Copy tempWK.Sheets(BYSHNAME).Range("1:1")
    
44.     tempWK.SaveAs ThisWorkbook.Path & "" & temp
    
45.     tempWK.Close True
    
46. Next
    
47. 
    
48. Set dic = Nothing
    
49. Set rng = Nothing
    
50. ThisWorkbook.Sheets(1).Select
    
51. 
    
52. 
    
53.    
    
54.    
    
55. 
    
56. End Sub
    
57. 
    
58. 
    

复制代码

Hoer

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

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

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

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

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

fdd

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

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

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

1. 
   
2. Option Explicit
   
3. Sub addWK2()
   
4. Dim dic, temp, arr, tempWK, temp2
   
5. Dim rng As Range
   
6. Const BYSHNAME As String = "数据表" '可以修改根据哪一个工作表拆分工作簿
   
7. Application.ScreenUpdating = False
   
8. Set dic = CreateObject("scripting.dictionary") '字典
   
9. '下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
   
10. Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("b2:b" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
    
11. For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
    
12.     If Not dic.exists(temp.Value) Then
    
13.         dic.Add temp.Value, ""
    
14.     End If
    
15. Next
    
16. arr = dic.keys '返回此列不重复值的数组
    
17. 
    
18. For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并复制应有的内容
    
19.     ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "" & temp & ".xls" '以当前temp的值为新工作簿的名称，备份当前工作簿
    
20.    
    
21.    
    
22.    
    
23.     Set tempWK = Workbooks.Open(ThisWorkbook.Path & "" & temp & ".xls") '打开以temp的值为名称的工作簿
    
24.    
    
25.    
    
26.         
    
27.         tempWK.Sheets(BYSHNAME).Cells.Clear '清除该工作簿以BYSHNAME为名称的工作表的所有内容
    
28.    
    
29.     For Each temp2 In rng '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，相同即复制相关内容
    
30.         If temp2 = temp Then
    
31.         '下面代码：temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy是复制源工作表的从A-D列的内容
    
32.         '代码tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)是获取tempWK工作簿以BYSHNAME为名称的工作表的最后列的下一行第一列的位置
    
33.             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)
    
34.             
    
35.         End If
    
36.     Next
    
37.     ThisWorkbook.Sheets(BYSHNAME).Range("1:1").Copy tempWK.Sheets(BYSHNAME).Range("1:1") '复制标题栏
    
38.     tempWK.Save
    
39.     tempWK.Close
    
40. Next
    
41. Application.ScreenUpdating = True
    
42. Set dic = Nothing
    
43. Set rng = Nothing
    
44. ThisWorkbook.Sheets(1).Select
    
45. 
    
46.    
    
47.    
    
48. End Sub
    

复制代码

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

Hoer

速度的话我修改了一下代码，即拷贝好工作表，然用筛选后再删除的办法比较快~~
   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

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

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