[已解决][求助] 自定义选项卡使用宏时，copy方法作用失败

youszhang

1. Sub CombineWorkbooks()
   
2. Dim FilesToOpen
   
3. Dim x As Integer
   
4. On Error GoTo errhandler
   
5. Application.ScreenUpdating = False '禁用屏幕刷新
   
6. FilesToOpen = Application.GetOpenFilename(Filefilter:="MicroSoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="要合并的文件")
   
7. If TypeName(FilesToOpen) = "Boolean" Then
   
8. MsgBox "没有选中文件"
   
9. GoTo exithandler
   
10. End If
    
11. x = 1
    
12. While x <= UBound(FilesToOpen)
    
13. Workbooks.Open Filename:=FilesToOpen(x)
    
14. '只选每个工作簿的sheet1,Copy可以为Move，两者有差别，从字面意思可以理解。
    
15. '最好是用Copy，否则原来的数据可能会被破坏。
    
16. Sheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
17. x = x + 1
    
18. Wend
    
19. exithandler:
    
20. Application.ScreenUpdating = True '恢复屏幕刷新
    
21. Workbooks.Close '新增关闭文件函数
    
22. Exit Sub
    
23. errhandler:
    
24. MsgBox Err.Description
    
25. Resume exithandler
    
26. End Sub

复制代码

以上是多工作表合并到一个工作薄的代码，我在excel2010使用自定义选项卡指定宏的时候，执行到一半就出现类似方法失败的对话框，是为什么呢？请大家帮我看看。谢谢哦

最佳答案

月排行榜 / 总排行榜

吕?布

2012-3-7 17:24

好象没有问题啊，有一个可能是你某个文件中某个单元格的长度太长，要不把你将要合并的文件发上来测试，
附件是我用的合并程序 多工作簿合并.rar (13.73 KB, 下载次数: 7)

2012-3-7 17:24 上传

点击文件名下载附件

Option Explicit

'Callback for tabZbhpass.groupTmp.buttonCombineWorkbooks onAction
Sub CombineWorkbooks(control As IRibbonControl)
    Dim FilesToOpen As Variant
    Dim x As Integer
    Dim wbResult As Workbook
    Dim wbTemp As Workbook

    On Error GoTo errhandler
    Application.ScreenUpdating = False '禁用屏幕刷新
    FilesToOpen = Application.GetOpenFilename(Filefilter:="MicroSoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="要合并的文件")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "没有选中文件"
        GoTo exithandler
    End If

    x = 1
    Set wbResult = Workbooks.Add
    While x <= UBound(FilesToOpen)
        Set wbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
        wbTemp.Sheets.Copy after:=wbResult.Sheets(ThisWorkbook.Sheets.Count)
        x = x + 1
        wbTemp.Close
    Wend
exithandler:
    Application.ScreenUpdating = True '恢复屏幕刷新
    'Workbooks.Close '新增关闭文件函数
    Exit Sub
errhandler:
    MsgBox Err.Description
    Resume exithandler
End Sub

跳转到最佳答案楼层

那么的帅

提供数据附件，以便测试代码

学习进行了

                                                  

youszhang

那么的帅 发表于 2012-3-7 11:15
提供数据附件，以便测试代码

你好，这个没有数据附件的哦，具体请见附图。谢谢哈

adders

Sheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

改成:

Sheets("Sheet1").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

吕?布

就是要提供你的选项卡文件，不然怎么测试问题出在哪，怎不能猜测楼主的意思再自己写一个吧

youszhang

吕?布 发表于 2012-3-7 11:40
就是要提供你的选项卡文件，不然怎么测试问题出在哪，怎不能猜测楼主的意思再自己写一个吧

OK，我明白了，谢谢哈，已上传

youszhang

adders 发表于 2012-3-7 11:38
Sheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

改成:

谢谢哦，代码已测试，出现另一个问题：

1. Sub CombineWorkbooks1()
   
2. Dim FilesToOpen
   
3. Dim x As Integer
   
4. Dim wb As Workbook
   
5. On Error GoTo errhandler
   
6. Application.ScreenUpdating = False '禁用屏幕刷新
   
7. FilesToOpen = Application.GetOpenFilename(Filefilter:="MicroSoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="要合并的文件")
   
8. If TypeName(FilesToOpen) = "Boolean" Then
   
9. MsgBox "没有选中文件"
   
10. GoTo exithandler
    
11. End If
    
12. x = 1
    
13. While x <= UBound(FilesToOpen)
    
14. Set wb = Workbooks.Open(Filename:=FilesToOpen(x))
    
15. '只选每个工作簿的sheet1,Copy可以为Move，两者有差别，从字面意思可以理解。
    
16. '最好是用Copy，否则原来的数据可能会被破坏。
    
17. wb.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
18. wb.Close
    
19. x = x + 1
    
20. Wend
    
21. exithandler:
    
22. Application.ScreenUpdating = True '恢复屏幕刷新
    
23. 'Workbooks.Close '新增关闭文件函数
    
24. Exit Sub
    
25. errhandler:
    
26. MsgBox Err.Description
    
27. 'Resume exithandler
    
28. End Sub

复制代码

如果使用wb.Sheets（"sheet1"），则提示下标越界，不知是为什么

吕?布

好象没有问题啊，有一个可能是你某个文件中某个单元格的长度太长，要不把你将要合并的文件发上来测试，
附件是我用的合并程序 多工作簿合并.rar (13.73 KB, 下载次数: 7)

2012-3-7 17:24 上传

点击文件名下载附件

Option Explicit

'Callback for tabZbhpass.groupTmp.buttonCombineWorkbooks onAction
Sub CombineWorkbooks(control As IRibbonControl)
    Dim FilesToOpen As Variant
    Dim x As Integer
    Dim wbResult As Workbook
    Dim wbTemp As Workbook

    On Error GoTo errhandler
    Application.ScreenUpdating = False '禁用屏幕刷新
    FilesToOpen = Application.GetOpenFilename(Filefilter:="MicroSoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="要合并的文件")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "没有选中文件"
        GoTo exithandler
    End If

    x = 1
    Set wbResult = Workbooks.Add
    While x <= UBound(FilesToOpen)
        Set wbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
        wbTemp.Sheets.Copy after:=wbResult.Sheets(ThisWorkbook.Sheets.Count)
        x = x + 1
        wbTemp.Close
    Wend
exithandler:
    Application.ScreenUpdating = True '恢复屏幕刷新
    'Workbooks.Close '新增关闭文件函数
    Exit Sub
errhandler:
    MsgBox Err.Description
    Resume exithandler
End Sub

adders

youszhang 发表于 2012-3-6 23:46
谢谢哦，代码已测试，出现另一个问题：
如果使用wb.Sheets（"sheet1"），则提示下标越界，不知是为什么

ok, 下标越界是因为你选中的工作簿不是每一个都有一个名叫"Sheet1"的工作表.

先纠正我前面的一个说法,sheets.copy应该是可行的.

这个Copy方法失败应该是Excel的一个bug,当你一次拷贝太多的工作表而中间没有保存时,会有这个错误提示.有的人试验是在copy到30至40个工作表左右出现,不过微软的意思似乎是:到多少个表会失败取决于你Copy过来的工作表的size.

我没有找到补丁,但是找到这个: http://support.microsoft.com/kb/210684/en-us

根据微软的说法,在COPY一些Sheets后要保存一下工作簿,再进行COPY,直到把你需要的表全部COPY完.你可以把定期保存(比如每保存25个Sheets就保存一下工作簿,微软的示例中是copy 100个Sheets, 保存关闭工作簿,再重新打开工作簿,再loop)写进你的代码中,再测试一下.

微软示例部分代码:

1.     For iCounter = 1 To 275
   
2.         oBook.Worksheets(1).Copy After:=oBook.Worksheets(1)
   
3.         'Uncomment this code for the workaround:
   
4.         'Save, close, and reopen after every 100 iterations:
   
5.         If iCounter Mod 100 = 0 Then
   
6.             oBook.Close SaveChanges:=True
   
7.             Set oBook = Nothing
   
8.             Set oBook = Application.Workbooks.Open("c:\test2.xls")
   
9.         End If
   
10.     Next
    

复制代码