如何合并不同工作簿中的同名工作表

chenmeidi

感谢楼上的大师的回答，可本人太低级了，实在搞不明白，太深奥了。
我的要合并的工作簿都设了工作表保护密码和工作簿保护密码，密码都是同一个“0”，但打开工作簿没有设定密码。
这段代码：  Set Wk = Workbooks.Open(MyPath & "\" & MyName, Password:="123", WriteResPassword:="456")
该插在哪儿，菜鸟反复测试，吃不消啊，希望高手帮帮忙，最好把整段代码帮我整理好，我要向高手们好好学习。

zhaogang1960

chenmeidi 发表于 2011-12-21 22:40
Sub combo()
Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName, t%
t = Val(InputBo ...

如果是打开工作簿需要密码，加上密码打开即可，如：
Set Wk = Workbooks.Open(MyPath & "\" & MyName, Password:="123", WriteResPassword:="456")

chenmeidi

Sub combo()
Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName, t%
t = Val(InputBox("请选择工作表序号", , 1))
If t = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Name <> ActiveSheet.Name Then sh.Delete
Next
n = 1
MyPath = ThisWorkbook.Path & "\"   '指定路径
MyName = Dir(MyPath & "\" & "*.xls")    '寻找第一项
Do While MyName <> ""    '开始循环
If MyName <> ThisWorkbook.Name Then
Set Wk = Workbooks.Open(MyPath & "\" & MyName)
Wk.Sheets(t).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '此处只插个第一个sheet
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Name = Mid(MyName, 1, Len(MyName) - 4) '重新命名sheet
.UsedRange.Value = .UsedRange.Value
End With
Wk.Close False
End If
MyName = Dir    '查找下一个
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
这个代码，正是我需要的了，只不过有要合并的工作簿一般都是加密锁定的，运行不了，如果要一个个解密，要耗费很多时间，请高手能指点，帮忙修改，我是菜鸟，才开始蹒跚学步。

kszcs

收藏起来，学习了

chenmeidi

zhaogang1960 发表于 2011-12-21 22:58
如果是打开工作簿需要密码，加上密码打开即可，如：
Set Wk = Workbooks.Open(MyPath & "\" & MyName, P ...

1. Sub combo()
   
2. Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName, t%
   
3. t = Val(InputBox("请选择工作表序号", , 1))
   
4. If t = 0 Then Exit Sub
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayAlerts = False
   
7. For Each sh In Sheets
   
8.     If sh.Name <> ActiveSheet.Name Then sh.Delete
   
9. Next
   
10. n = 1
    
11. MyPath = ThisWorkbook.Path & ""   '指定路径
    
12. MyName = Dir(MyPath & "" & "*.xls")    '寻找第一项
    
13. Do While MyName <> ""    '开始循环
    
14. If MyName <> ThisWorkbook.Name Then
    
15. Set Wk = Workbooks.Open(MyPath & "" & MyName)
    
16. Wk.Sheets(t).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '此处只插个第一个sheet
    
17. With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
18. .Name = Mid(MyName, 1, Len(MyName) - 4) '重新命名sheet
    
19. .UsedRange.Value = .UsedRange.Value
    
20. End With
    
21. Wk.Close False
    
22. End If
    
23. MyName = Dir    '查找下一个
    
24. Loop
    
25. Application.ScreenUpdating = True
    
26. Application.DisplayAlerts = True
    
27. End Sub
    

复制代码

麻烦大师再帮我修改一下代码，本人迫切需要这种合并功能，可太深奥了，能力有限，正在学习中。

zhaogang1960

chenmeidi 发表于 2011-12-22 22:49
麻烦大师再帮我修改一下代码，本人迫切需要这种合并功能，可太深奥了，能力有限，正在学习中。

用下面一句替换原来的Set Wk = Workbooks.Open(MyPath & "\" & MyName)
Set Wk = Workbooks.Open(MyPath & "\" & MyName, Password:="123", WriteResPassword:="456")
如果只有打开密码，保留第一个即可，自己修改一下密码

chenmeidi

先谢谢赵老师了，我的工作簿打开没有设定密码，是工作表保护设定了密码“0”，
我用了你的修改的代码，运行时出现下列对话框
只有求助于你了，我前后两个都改成密码0，都用上去也不行，单独用前面的密码也不行，单独用后面的密码也不行，测试代码时看到代码 .UsedRange.Value = .UsedRange.Value   出现黄色标志了。
抽空帮我解决一下我的难题，麻烦你这么多，真是不好意思。

chenmeidi

请各位大师帮个忙，本人刚接触vba，对代码的编写不太懂，正在学习阶段，水平有限，麻烦大师给按我的意图编写或修改代码，我在线等了很多天了，能得到大师们的帮助或点拨，本人不胜感激，附件附后。

zhaogang1960

chenmeidi 发表于 2011-12-27 22:53
请各位大师帮个忙，本人刚接触vba，对代码的编写不太懂，正在学习阶段，水平有限，麻烦大师给按我的意图编写 ...

1. Sub combo()
   
2. Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName, t%
   
3. t = Val(InputBox("请选择工作表序号", , 1))
   
4. If t = 0 Then Exit Sub
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayAlerts = False
   
7. For Each sh In Sheets
   
8.     If sh.Name <> ActiveSheet.Name Then sh.Delete
   
9. Next
   
10. n = 1
    
11. MyPath = ThisWorkbook.Path & ""   '指定路径
    
12. MyName = Dir(MyPath & "" & "*.xls")    '寻找第一项
    
13. Do While MyName <> ""    '开始循环
    
14. If MyName <> ThisWorkbook.Name Then
    
15. Set Wk = Workbooks.Open(MyPath & "" & MyName)
    
16. Wk.Sheets(t).Unprotect (0) '这里加一句解除密码
    
17. Wk.Sheets(t).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '此处只插个第一个sheet
    
18. With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
19. .Name = Mid(MyName, 1, Len(MyName) - 4) '重新命名sheet
    
20. .UsedRange.Value = .UsedRange.Value
    
21. End With
    
22. Wk.Close False
    
23. End If
    
24. MyName = Dir    '查找下一个
    
25. Loop
    
26. Application.ScreenUpdating = True
    
27. Application.DisplayAlerts = True
    
28. End Sub
    

复制代码

chenmeidi

zhaogang1960 发表于 2011-12-27 23:09

太感谢大师了，完全达到了我的要求了，大师真是太厉害了，我要慢慢学着，遇到问题还得请教你、麻烦你，O(∩_∩)O~，再次谢谢哦。