[已解决]为每个工作簿添加相同工作表

hazel.zhao

请问如何批量为同一个文件夹中的每一个工作簿添加一个带内容的相同名称的工作表？？

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-25 16:53

1. Sub Macro1()
   
2. Dim arr, wb As Workbook, i&, n&
   
3. Set wb = ThisWorkbook
   
4. arr = Range("a1:d" & Range("a65536").End(xlUp).Row + 1)
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayAlerts = False
   
7. Application.SheetsInNewWorkbook = 2
   
8. n = 2
   
9. For i = 3 To UBound(arr)
   
10.     If arr(i, 1) <> arr(i - 1, 1) Then
    
11.         Set rng = Range(Cells(n, 1), Cells(i - 1, 4))
    
12.         With Workbooks.Add
    
13.             wb.Sheets(1).Rows(1).Copy [a1]
    
14.             rng.Copy [a2]
    
15.             wb.Sheets(2).UsedRange.Copy Sheets(2).[a1]
    
16.             Sheets(1).Name = arr(i - 1, 1)
    
17.             Sheets(2).Name = "总表"
    
18.             .SaveAs Filename:=ThisWorkbook.Path & "" & arr(i - 1, 1) & ".xls"
    
19.             .Close 0
    
20.         End With
    
21.         n = i
    
22.     End If
    
23. Next
    
24. MsgBox "OK"
    
25. Application.SheetsInNewWorkbook = 3
    
26. Application.DisplayAlerts = True
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

跳转到最佳答案楼层

爱疯

“添加一个带内容的相同名称的工作表”，是什么意思？
不清楚结果是怎样的？
建议具体举例说明。

hazel.zhao

我是想把附件图片中11111工作薄的表“汇总”一次性添加到与其在同一文件夹下的其他工作簿中。

爱疯

是按A列拆分成3个工作簿吗

hazel.zhao

不是啦，拆分已经完成了，就是想在拆分好的各个分表里再添加一个总表。

hazel.zhao

这是原文件和我想达到的最后效果，请帮忙看下，多谢啦~

hazel.zhao

这只是举例，实际工作中有很多表要分，粘贴复制太麻烦

dsmch

1. Sub Macro1()
   
2. Dim arr, wb As Workbook, i&, n&
   
3. Set wb = ThisWorkbook
   
4. arr = Range("a1:d" & Range("a65536").End(xlUp).Row + 1)
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayAlerts = False
   
7. Application.SheetsInNewWorkbook = 2
   
8. n = 2
   
9. For i = 3 To UBound(arr)
   
10.     If arr(i, 1) <> arr(i - 1, 1) Then
    
11.         Set rng = Range(Cells(n, 1), Cells(i - 1, 4))
    
12.         With Workbooks.Add
    
13.             wb.Sheets(1).Rows(1).Copy [a1]
    
14.             rng.Copy [a2]
    
15.             wb.Sheets(2).UsedRange.Copy Sheets(2).[a1]
    
16.             Sheets(1).Name = arr(i - 1, 1)
    
17.             Sheets(2).Name = "总表"
    
18.             .SaveAs Filename:=ThisWorkbook.Path & "" & arr(i - 1, 1) & ".xls"
    
19.             .Close 0
    
20.         End With
    
21.         n = i
    
22.     End If
    
23. Next
    
24. MsgBox "OK"
    
25. Application.SheetsInNewWorkbook = 3
    
26. Application.DisplayAlerts = True
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

dsmch

………………

hazel.zhao

如果是按照第四列分表，且要分的表有很多行、很多列，需要改哪些数据？