工作表拆分为单独文件

jzheyifan

1、将A列和B列作为表头，每一列单独输出为一个excel文件，sheet名称为“项目概况表”，文件名称为："项目概况表 "+第7行+第4行+第16行+第5行
2、保存到指定位置
3、目标文件是想要生成的最终文件
写了部分代码，不能运行，请忽略。

大头菜871118

>>>>>>>>>>>>>>>

abc123281

仅供参考

1. Sub 拆分()
   
2.   Dim arr
   
3.   Dim rng As Range
   
4.   Dim rng1 As Range
   
5.   Dim wb As Workbook
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   With Worksheets("项目概况表")
   
9.     bb = .Name
   
10.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
11.     arr = .Range("a1:e" & r)
    
12.     Set rng = .Range("a1:b" & r)
    
13.     For j = 3 To 5
    
14.        Set rng1 = .Range(.Cells(1, j), .Cells(r, j))
    
15.        aa = .Cells(7, j) & "  " & .Cells(4, j) & "  " & .Cells(16, j) & "  " & .Cells(5, j)
    
16.        Set wb = Workbooks.Add
    
17.        With wb
    
18.          With .Worksheets(1)
    
19.              rng.Copy .[a1]
    
20.              rng1.Copy .[c1]
    
21.             .Columns("A:A").ColumnWidth = 8
    
22.             .Columns("b:c").ColumnWidth = 22
    
23.             .Name = "项目概况表"
    
24.          End With
    
25.         .SaveAs Filename:=ThisWorkbook.Path & "\目标文件" & bb & "  " & aa
    
26.         .Close False
    
27.        End With
    
28.     Next j
    
29.   End With
    
30.   Application.ScreenUpdating = True
    
31.   MsgBox "数据拆分完毕！"
    
32. End Sub

复制代码

abc123281

参考附件




工作表拆分abc123.rar (27.14 KB, 下载次数: 39)

2018-3-21 19:47 上传

点击文件名下载附件

abc123281

呵呵  非常感谢乐乐的鲜花支持与鼓励

jzheyifan

abc123281 发表于 2018-3-21 19:46
仅供参考

老师，计算第四行的列数代码怎么写？

abc123281

cl = .Cells(4, .Columns.Count).End(xlToLeft).Column

jzheyifan

abc123281 发表于 2018-3-22 10:04
cl = .Cells(4, .Columns.Count).End(xlToLeft).Column

谢谢老师！

2801959927

试一试

1. Option Explicit
   
2. Sub 每列保存为一个文件()
   
3.     Dim rng, col%, rng_col, the_path$
   
4.     the_path = "D:\Documents\99Others\Excelhome\工作表拆分\目标文件"
   
5.     MkDir the_path      '确保先删除原有文件夹
   
6.     rng = Sheet1.Range("A1:B204").Value: col = 3
   
7.     Application.ScreenUpdating = False
   
8.     Do While Len(Cells(2, col)) > 0
   
9.         rng_col = Sheet1.Range(Cells(2, col), Cells(203, col)).Value
   
10.         Workbooks.Add
    
11.         With ActiveWorkbook.ActiveSheet
    
12.             .Range("A1").Resize(203, 2) = rng
    
13.             .Range("C2").Resize(202, 1) = rng_col
    
14.             .Cells.EntireColumn.AutoFit
    
15.             .Cells.HorizontalAlignment = xlCenter
    
16.         End With
    
17.         ActiveWorkbook.SaveAs the_path & "" & "项目概况表 " & Cells(7, 3).Text & " " & Cells(4, 3).Text _
    
18.             & " " & Cells(16, 3).Text & " " & Cells(5, 3).Text
    
19.         ActiveWorkbook.Close True
    
20.         col = col + 1
    
21.     Loop
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码