多个相同工作表的工作簿如何快速拆分后组合成新的工作簿？

yschaizhen · 发表于 2016-5-19 17:33

本帖最后由 yschaizhen 于 2016-5-19 18:20 编辑

附件数据文件夹中有茶盘、蓼叶、通天、西桥4个工作薄（实际可能上百个），每工作簿中有报表1、报表2、报表3、报表 4四张工作表，如何快速把这4个工作簿按工作表拆分并生成成结果文件夹中的工作薄。

yschaizhen · 发表于 2016-5-19 18:00

希望在线的老师帮助，谢谢！！！！

cqlpjxx · 发表于 2016-5-20 07:49

yschaizhen 发表于 2016-5-19 18:00
希望在线的老师帮助，谢谢！！！！

思路：1.如果报表只有4个的话，可以先建4个空工作薄：报表1---报表4
2.打开报表1，将数据工作簿的所有报表1汇总

yschaizhen · 发表于 2016-5-20 09:31

cqlpjxx 发表于 2016-5-20 07:49
思路：1.如果报表只有4个的话，可以先建4个空工作薄：报表1---报表4
2.打开报表1，将数据工作簿的所有报 ...

老师我的报表有上百个，你的思路太费时了，能写点代码帮我一下吗？

cqlpjxx · 发表于 2016-5-20 09:45

'在数据目录下，新一个excel文件，执行如下代码
Sub zz()
Dim myPath$, myFile$, Aiv As Workbook, sh1, j, brr, Aiv2 As Workbook
Application.DisplayAlerts = False  '关闭提示窗
Application.ScreenUpdating = False
On Error Resume Next
For Each sh1 In ThisWorkbook.Sheets
      brr = sh1.Range("A2:H" & sh1.Range("A65536").End(3).Row)
      myPath = ThisWorkbook.Path & "\"    '把文件路径定义给变量
      myFile = Dir(myPath & "*.xls")          '依次找寻指定路径中的*.xls文件
      Do While myFile <> ""                   '当指定路径中有文件时进行循环

         If myFile <> ThisWorkbook.Name Then
            Set Aiv = Workbooks.Open(myPath & myFile)       '打开符合要求的文件
            Dim arr, m, i, sh
            For Each sh In Aiv.Sheets
                  Set Aiv2 = Workbooks.Open(myPath & "结果\" & sh.Name & ".xlsx") '打开结果文件
                  sh.Copy After:=Aiv2.Sheets(1)          '复制工作表
                  Aiv2.Sheets(sh.Name).Name = Aiv.Name '改表名
                  Aiv2.Close True  '关闭工作簿
            Next
            Workbooks(myFile).Close False             '关闭源工作簿
         End If
         myFile = Dir          '找寻下一个*.xls文件
         MsgBox myFile
      Loop
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

yschaizhen · 发表于 2016-5-20 10:42

cqlpjxx 发表于 2016-5-20 09:45
'在数据目录下，新一个excel文件，执行如下代码
Sub zz()
Dim myPath$, myFile$, Aiv As Workbook, s ...

按老师的方法执行代码后，每打开一个工作薄要点击一下确定，结果文件夹中也没有生成报表1-报表4四个工作薄，麻烦老师看看。

cqlpjxx · 发表于 2016-5-20 13:03

yschaizhen 发表于 2016-5-20 10:42
按老师的方法执行代码后，每打开一个工作薄要点击一下确定，结果文件夹中也没有生成报表1-报表4四个工作 ...

'修改了一下代码，请测试
Sub zz()
Dim myPath$, myFile$, Aiv As Workbook, i, sh, Aiv2 As Workbook
Application.DisplayAlerts = False  '关闭提示窗
Application.ScreenUpdating = False
On Error Resume Next
brr = sh1.Range("A2:H" & sh1.Range("A65536").End(3).Row)
myPath = ThisWorkbook.Path & "\"    '把文件路径定义给变量
myFile = Dir(myPath & "*.xls")          '依次找寻指定路径中的*.xls文件
For i = 1 To 4
      Workbooks.Add
      ActiveWorkbook.SaveAs Filename:= _
                           myPath & "结果\报表" & i & ".xlsx"
Next

Do While myFile <> ""                   '当指定路径中有文件时进行循环
      If myFile <> ThisWorkbook.Name Then
         Set Aiv = Workbooks.Open(myPath & myFile)       '打开符合要求的文件

         For Each sh In Aiv.Sheets
            Set Aiv2 = Workbooks(sh.Name & ".xlsx")
            sh.Copy After:=Aiv2.Sheets(1)          '复制工作表
            Aiv2.Sheets(sh.Name).Name = Aiv.Name '改表名
            '
         Next
         Workbooks(myFile).Close False             '关闭源工作簿
      End If
      myFile = Dir          '找寻下一个*.xls文件
Loop
For i = 1 To 4
      Workbooks("报表" & i & ".xlsx").Close True '关闭保存工作簿
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

cqlpjxx · 发表于 2016-5-20 13:06

请测试......................................

yschaizhen · 发表于 2016-5-20 15:25

cqlpjxx 发表于 2016-5-20 13:06
请测试......................................

谢谢老师，经测试还有以下问题， 1、新生成的工作簿的工作表名称多了xls, 2、多了Sheet1-Sheet3三个空表，3、如果数据工作表中某个工作薄还有报表5或报表6，拆分后不能新生成报表5或报表6工作薄。
麻烦老师再修改一下，谢谢。

cqlpjxx · 发表于 2016-5-20 17:11

yschaizhen 发表于 2016-5-20 15:25
谢谢老师，经测试还有以下问题， 1、新生成的工作簿的工作表名称多了xls, 2、多了Sheet1-Sheet3三个空表 ...

Sub zz()
Dim myPath$, myFile$, Aiv As Workbook, i, n, m, sh, Aiv2 As Workbook
Application.DisplayAlerts = False  '¹Ø±ÕÌáÊ¾´°
Application.ScreenUpdating = False
On Error Resume Next
brr = sh1.Range("A2:H" & sh1.Range("A65536").End(3).Row)
myPath = ThisWorkbook.Path & "\"    '°ÑÎÄ¼þÂ·¾¶¶¨Òå¸ø±äÁ¿
myFile = Dir(myPath & "*.xls")          'ÒÀ´ÎÕÒÑ°Ö¸¶¨Â·¾¶ÖÐµÄ*.xlsÎÄ¼þ
      n = 0
      Do While myFile <> ""                   'µ±Ö¸¶¨Â·¾¶ÖÐÓÐÎÄ¼þÊ±½øÐÐÑ»·
      If myFile <> ThisWorkbook.Name Then
         Set Aiv = Workbooks.Open(myPath & myFile)       '´ò¿ª·ûºÏÒªÇóµÄÎÄ¼þ
         m = Aiv.Sheets.Count
         If m > n Then
         For i = n + 1 To m
         Workbooks.Add
         ActiveWorkbook.SaveAs Filename:= _
                           myPath & "½á¹û\±¨±í" & i & ".xlsx"
         Next
         n = m
         End If

         For Each sh In Aiv.Sheets
            Set Aiv2 = Workbooks(sh.Name & ".xlsx")
            sh.Copy After:=Aiv2.Sheets(1)          '¸´ÖÆ¹¤×÷±í
            Aiv2.Sheets(sh.Name).Name = Mid(Aiv.Name, 1, Len(Aiv.Name) - 4) '¸Ä±íÃû
            '
         Next
         Workbooks(myFile).Close False             '¹Ø±ÕÔ´¹¤×÷²¾
      End If
      myFile = Dir          'ÕÒÑ°ÏÂÒ»¸ö*.xlsÎÄ¼þ
Loop
For i = 1 To n
      Workbooks("±¨±í" & i & ".xlsx").Sheets("Sheet1").Delete
      Workbooks("±¨±í" & i & ".xlsx").Sheets("Sheet2").Delete
      Workbooks("±¨±í" & i & ".xlsx").Sheets("Sheet3").Delete
      Workbooks("±¨±í" & i & ".xlsx").Close True '¹Ø±Õ±£´æ¹¤×÷²¾
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

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

[求助] 多个相同工作表的工作簿如何快速拆分后组合成新的工作簿？