[已解决]请问如何批量为同文件夹中的每个工作簿插入另一个表格

541181001

大家好，请教一下如何批量把一个表格插入到文件夹中的所有表格中的最前面，谢谢

最佳答案

月排行榜 / 总排行榜

810126769

2014-5-7 18:24

请测试：

批量为同文件夹中的每个工作簿插入另一个表格.rar (128.58 KB, 下载次数: 135)

2014-5-7 20:04 上传

点击文件名下载附件

1. Option Explicit
   
2. 
   
3. Sub 插入目录()
   
4. Dim myname$, mypath$, i&
   
5. Sheets("目录").Cells.Copy
   
6. mypath = ThisWorkbook.Path & "\把目录插入到文件夹中的所有表格的最前面"
   
7. myname = Dir(mypath & "*.xls*")
   
8. Do While myname <> ""
   
9.    With Workbooks.Open(mypath & myname)
   
10.         For i = 1 To .Sheets.Count
    
11.             If .Sheets(i).Name = "目录" Then
    
12.                 MsgBox "已经存在“目录”"
    
13.                 .Close False
    
14.                 GoTo PPP
    
15.             End If
    
16.         Next i
    
17.           .Sheets.Add before:=Sheets(1)
    
18.          ActiveSheet.Name = "目录"
    
19.          ThisWorkbook.Sheets("目录").Cells.Copy
    
20.         .Sheets("目录").[a1].PasteSpecial Paste:=xlPasteAll
    
21.         .RemovePersonalInformation = False
    
22.         .Close True
    
23.    End With
    
24. PPP:
    
25.    myname = Dir
    
26. Loop
    
27. Application.CutCopyMode = False
    
28. End Sub
    

复制代码

跳转到最佳答案楼层

810126769

请测试：

批量为同文件夹中的每个工作簿插入另一个表格.rar (128.58 KB, 下载次数: 135)

2014-5-7 20:04 上传

点击文件名下载附件

1. Option Explicit
   
2. 
   
3. Sub 插入目录()
   
4. Dim myname$, mypath$, i&
   
5. Sheets("目录").Cells.Copy
   
6. mypath = ThisWorkbook.Path & "\把目录插入到文件夹中的所有表格的最前面"
   
7. myname = Dir(mypath & "*.xls*")
   
8. Do While myname <> ""
   
9.    With Workbooks.Open(mypath & myname)
   
10.         For i = 1 To .Sheets.Count
    
11.             If .Sheets(i).Name = "目录" Then
    
12.                 MsgBox "已经存在“目录”"
    
13.                 .Close False
    
14.                 GoTo PPP
    
15.             End If
    
16.         Next i
    
17.           .Sheets.Add before:=Sheets(1)
    
18.          ActiveSheet.Name = "目录"
    
19.          ThisWorkbook.Sheets("目录").Cells.Copy
    
20.         .Sheets("目录").[a1].PasteSpecial Paste:=xlPasteAll
    
21.         .RemovePersonalInformation = False
    
22.         .Close True
    
23.    End With
    
24. PPP:
    
25.    myname = Dir
    
26. Loop
    
27. Application.CutCopyMode = False
    
28. End Sub
    

复制代码

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim sht As Worksheet, mypath$, wj$
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. Set sht = ThisWorkbook.Sheets("目录")
   
7. mypath = ThisWorkbook.Path & "\效果"
   
8. wj = Dir(mypath & "*.xls*")
   
9. Do While wj <> ""
   
10.     With Workbooks.Open(mypath & wj)
    
11.         If .Sheets("目录") Is Nothing Then sht.Copy before:=.Sheets(1)
    
12.     End With
    
13.     Workbooks(wj).Close 1
    
14.     wj = Dir
    
15. Loop
    
16. Application.DisplayAlerts = True
    
17. Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

dsmch

alt+f8执行代码，结果在效果文件夹中

541181001

810126769 发表于 2014-5-7 18:24
请测试：

运行的时候弹出兼容性检查器，能否加个继续保存？

15152665000

真的好用,谢谢您的辛苦劳动!