[已解决]求复制指定文件夹的工作簿的VBA代码

雪上人家

要求：用VBA，将文件夹《要复制的工作簿》中的BOOK1、BOOK2和BOOK3按顺序复制到工作簿“复制指定工作簿到此工作簿中”原有工作表2后，见红色标签的工作表。实际中，BOOK1、BOOK2、BOOK3……类似的文件簿有很多。
见附件。
琢磨了几天，解决不了，不知哪位老师知道，不胜感激！
复制工作簿.rar (5.38 KB, 下载次数: 50)

2011-9-25 10:23 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

mxg825

2011-9-25 11:07

回复 雪上人家 的帖子

1. Private Sub CommandButton1_Click()
   
2. Dim fs, f, fl, fc, s, fls, flsE
   
3. Dim Wb As Workbook
   
4. Dim She As Object
   
5. Dim Rng As Range
   
6. Set fs = CreateObject("Scripting.FileSystemObject") '创建FileSystemObject对象
   
7. Set f = fs.GetFolder(ThisWorkbook.Path & "\待处理") '创建文件夹对象
   
8. Application.DisplayAlerts = False '临时关闭EXCEL 系统提示
   
9. Set fls = f.Files '取得文件集合
   
10. With ThisWorkbook
    
11. For Each flsE In fls '历遍全部文件
    
12. If InStr(flsE.Name, ".xls") > 0 Then ''避免打开非Excel文件
    
13. Set Wb = Workbooks.Open(flsE) '打开工作薄
    
14. s = s + 1
    
15. Wb.Sheets(1).Copy after:=.Sheets(.Sheets.Count) '复制第一个工作表过来 新建
    
16. Wb.Close False '关闭被打开工作薄
    
17. Set Wb = Nothing '释放对象
    
18. .Sheets(.Sheets.Count).Name = Left(flsE.Name, Len(flsE.Name) - 4) '新工作表名称=工作薄名称
    
19. End If
    
20. Next
    
21. .Save '保存文件
    
22. End With
    
23. Application.DisplayAlerts = True
    
24. MsgBox "共处理了" & s & "工作薄"
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

mxg825

注意：使用EXCEL03版 复制的工作表总数不能超过250个 ()

mxg825

回复 雪上人家 的帖子

1. Private Sub CommandButton1_Click()
   
2. Dim fs, f, fl, fc, s, fls, flsE
   
3. Dim Wb As Workbook
   
4. Dim She As Object
   
5. Dim Rng As Range
   
6. Set fs = CreateObject("Scripting.FileSystemObject") '创建FileSystemObject对象
   
7. Set f = fs.GetFolder(ThisWorkbook.Path & "\待处理") '创建文件夹对象
   
8. Application.DisplayAlerts = False '临时关闭EXCEL 系统提示
   
9. Set fls = f.Files '取得文件集合
   
10. With ThisWorkbook
    
11. For Each flsE In fls '历遍全部文件
    
12. If InStr(flsE.Name, ".xls") > 0 Then ''避免打开非Excel文件
    
13. Set Wb = Workbooks.Open(flsE) '打开工作薄
    
14. s = s + 1
    
15. Wb.Sheets(1).Copy after:=.Sheets(.Sheets.Count) '复制第一个工作表过来 新建
    
16. Wb.Close False '关闭被打开工作薄
    
17. Set Wb = Nothing '释放对象
    
18. .Sheets(.Sheets.Count).Name = Left(flsE.Name, Len(flsE.Name) - 4) '新工作表名称=工作薄名称
    
19. End If
    
20. Next
    
21. .Save '保存文件
    
22. End With
    
23. Application.DisplayAlerts = True
    
24. MsgBox "共处理了" & s & "工作薄"
    
25. End Sub
    

复制代码

雪上人家

谢谢mxg825 老师了，我下来看一下

上面老师的代码确实好用，就是复制过来的表和原来的完全一样，公式也被复制过来，我想能不能直接将原表中的格式和公式计算出来的数据复制过来，我是菜鸟，希望老师指点指点。