ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 7760|回复: 15

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2009-2-16 19:43 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
一工作簿,包含3个工作表(分别是说明表、数据表、备注表),现要求根据“数据表”中的第2列(或第3列)进行拆分若干个工作簿,并且拆分后的若干工作簿都仍然包含3个工作表(分别是说明表、数据表(数据表中的数据因拆分有所减少)、备注表),即原工作簿中除“数据表”中数据因拆分有所减少外,“说明表”和“备注表”都原封不动地分别复制到拆分后的若干工作簿中。

不知朋友们看懂了没有~

例子.rar

2.1 KB, 下载次数: 169

工作簿拆分

TA的精华主题

TA的得分主题

发表于 2009-2-16 20:05 | 显示全部楼层
“拆分”的方法没看懂,楼主举个例吧!

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-2-16 20:15 | 显示全部楼层
如原工作簿中根据”数据表“第2列"类别"进行拆分,将工作簿拆分成A.XLS、B.XLS、C. XLS三个工作簿。

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

TA的精华主题

TA的得分主题

发表于 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 编辑 ]

TA的精华主题

TA的得分主题

 楼主| 发表于 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

TA的精华主题

TA的得分主题

发表于 2009-2-16 22:14 | 显示全部楼层
下面的代码只需设置:拆分依据表的名称及根据该表的第几列拆分工作簿 即可。
  1. Option Explicit

  2. Sub addWK()
  3. Dim dic, temp, arr, arrSh(), tempWK, temp2, i As Long
  4. Dim rng As Range
  5. Const BYSHNAME As String = "数据表"

  6. Set dic = CreateObject("scripting.dictionary")
  7. Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("b2:b" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
  8. For Each temp In rng.Cells
  9.     If Not dic.exists(temp.Value) Then
  10.         dic.Add temp.Value, ""
  11.     End If
  12. Next

  13. arr = dic.keys
  14. ReDim arrSh(1 To ThisWorkbook.Sheets.Count)

  15. For Each temp In Sheets
  16.     i = i + 1
  17.     arrSh(i) = temp.Name
  18. Next
  19. For Each temp In arr
  20.     ThisWorkbook.Sheets(arrSh).Select
  21.     ActiveSheet.Cells.Copy
  22.     Set tempWK = Workbooks.Add
  23.     tempWK.ActiveSheet.Cells.PasteSpecial
  24.     For i = 1 To ThisWorkbook.Sheets.Count
  25.    
  26.         tempWK.Sheets(i).Name = ThisWorkbook.Sheets(i).Name
  27.         
  28.         
  29.     Next
  30.         tempWK.Sheets(BYSHNAME).Activate
  31.         tempWK.Sheets(BYSHNAME).Cells.Clear
  32.    
  33.     For Each temp2 In rng
  34.         If temp2 = temp Then
  35.             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)
  36.             
  37.         End If
  38.     Next
  39.     ThisWorkbook.Sheets(BYSHNAME).Range("1:1").Copy tempWK.Sheets(BYSHNAME).Range("1:1")
  40.     tempWK.SaveAs ThisWorkbook.Path & "" & temp
  41.     tempWK.Close True
  42. Next

  43. Set dic = Nothing
  44. Set rng = Nothing
  45. ThisWorkbook.Sheets(1).Select


  46.    
  47.    

  48. End Sub


复制代码

TA的精华主题

TA的得分主题

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

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

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

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

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

TA的精华主题

TA的得分主题

发表于 2009-2-17 09:44 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
原帖由 Hoer 于 2009-2-17 06:40 发表
呵呵,差不多了,不过因为我对VBA的了解还比较肤浅,看了半天没看出个大概来,能不能再次麻烦fdd对上面这段代码做一个思路介绍及语句解释,帮助我理解上面这段代码,以便更好的利用代码。

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

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

  1. Option Explicit
  2. Sub addWK2()
  3. Dim dic, temp, arr, tempWK, temp2
  4. Dim rng As Range
  5. Const BYSHNAME As String = "数据表" '可以修改根据哪一个工作表拆分工作簿
  6. Application.ScreenUpdating = False
  7. Set dic = CreateObject("scripting.dictionary") '字典
  8. '下面一句代码:设置上面设置的工作表中的哪一列的内容拆分工作簿
  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 '这个for循环实现该列的不重复值的筛选
  11.     If Not dic.exists(temp.Value) Then
  12.         dic.Add temp.Value, ""
  13.     End If
  14. Next
  15. arr = dic.keys '返回此列不重复值的数组

  16. For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿,并复制应有的内容
  17.     ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "" & temp & ".xls" '以当前temp的值为新工作簿的名称,备份当前工作簿
  18.    
  19.    
  20.    
  21.     Set tempWK = Workbooks.Open(ThisWorkbook.Path & "" & temp & ".xls") '打开以temp的值为名称的工作簿
  22.    
  23.    
  24.         
  25.         tempWK.Sheets(BYSHNAME).Cells.Clear '清除该工作簿以BYSHNAME为名称的工作表的所有内容
  26.    
  27.     For Each temp2 In rng '这个for循环是比较源工作簿中拆分依据的工作表中,拆分依据的那一列与当前temp值是否相同,相同即复制相关内容
  28.         If temp2 = temp Then
  29.         '下面代码:temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy是复制源工作表的从A-D列的内容
  30.         '代码tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)是获取tempWK工作簿以BYSHNAME为名称的工作表的最后列的下一行第一列的位置
  31.             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)
  32.             
  33.         End If
  34.     Next
  35.     ThisWorkbook.Sheets(BYSHNAME).Range("1:1").Copy tempWK.Sheets(BYSHNAME).Range("1:1") '复制标题栏
  36.     tempWK.Save
  37.     tempWK.Close
  38. Next
  39. Application.ScreenUpdating = True
  40. Set dic = Nothing
  41. Set rng = Nothing
  42. ThisWorkbook.Sheets(1).Select

  43.    
  44.    
  45. End Sub
复制代码

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

TA的精华主题

TA的得分主题

 楼主| 发表于 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 编辑 ]

TA的精华主题

TA的得分主题

发表于 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 下一条

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-23 23:43 , Processed in 0.062219 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表