[已解决]移动工作表新建一个工作簿

要用就学

现在把“样表”工作簿所要的事，在您指导下已基本完成，最后是我想把“样表”这个工作簿里面除sheet1至sheet10以外的工作表全部移动到新建的工作簿。以写代码的工作表（也就是“样表”工作簿sheet10)b6-b10单元格的值为新建的工作表名字，b6,b7,b8,b9,b10，的值是连续的数字，“样表”shee10.[b6]有值时，新建的工作簿名字=[b6] ,如果“样表”sheet10.[b6:b9]值分别为102,103,104,105.那么新建的工作簿名字就是“102-105”，请问代码怎么写谢谢

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-7-13 20:29

要用就学 发表于 2013-7-13 18:49
谢谢指导（ ：）号我加上了但是无法运行，运行Set sht10 = Workbooks("Sheet10")
“9  下标越界”，我 ...

这里写错了，犯低级错误了。应该是WORKSHEETS("Sheet10")

跳转到最佳答案楼层

hwc2ycy

测试你来。

1. Sub test()
   
2. 
   
3.     On Error GoTo ErrorHandler
   
4.     Dim sht10 As Worksheet
   
5.     Dim sht As Worksheet
   
6.     Dim strPath As String
   
7.     Dim i As Long
   
8. 
   
9.     With Application
   
10.         .ScreenUpdating = False
    
11.         .DisplayAlerts = False
    
12.         .EnableEvents = False
    
13.         .Calculation = xlCalculationManual
    
14.     End With
    
15. 
    
16.     strPath = ThisWorkbook.Path & Application.PathSeparator
    
17.     Set sht10 = Workbooks("Sheet10")
    
18. 
    
19.     i = 6
    
20.     For Each sht In Worksheets
    
21.         If Len(sht10.Range("b" & i).Value) Then
    
22.             If Not (sht.Name Like "Sheet[1-9]" Or sht.Name Like "Sheet10") Then
    
23.                 sht.Move
    
24.                 ActiveWorkbook.SaveAs Filename = strPath & sht10.Range("b" & i).Value & ".xls", FileFormat:=xlExcel8
    
25.                 ActiveWorkbook.Close False
    
26.                 i = i + 1
    
27.             End If
    
28.         End If
    
29.     Next
    
30. 
    
31.     With Application
    
32.         .ScreenUpdating = True
    
33.         .DisplayAlerts = True
    
34.         .EnableEvents = True
    
35.         .Calculation = xlCalculationAutomatic
    
36.     End With
    
37. 
    
38. ErrorHandler:
    
39.     MsgBox Err.Number & vbCrLf & Err.Description
    
40.     With Application
    
41.         .ScreenUpdating = True
    
42.         .DisplayAlerts = True
    
43.         .EnableEvents = True
    
44.         .Calculation = xlCalculationAutomatic
    
45.     End With
    
46. End Sub
    

复制代码

hwc2ycy

ActiveWorkbook.SaveAs Filename = strPath & sht10.Range("b" & i).Value & ".xls", FileFormat:=xlExcel8
要改为
ActiveWorkbook.SaveAs Filename:= strPath & sht10.Range("b" & i).Value & ".xls", FileFormat:=xlExcel8

漏了个冒号。

甲百

现在把“样表”工作簿所要的事，在您指导下已基本完成，?/ 原贴在哪里?

要用就学

hwc2ycy 发表于 2013-7-13 13:56
测试你来。

谢谢指导（ ：）号我加上了但是无法运行，运行Set sht10 = Workbooks("Sheet10")
“9  下标越界”，我不知道是什么意思，请指教。

hwc2ycy

要用就学 发表于 2013-7-13 18:49
谢谢指导（ ：）号我加上了但是无法运行，运行Set sht10 = Workbooks("Sheet10")
“9  下标越界”，我 ...

这里写错了，犯低级错误了。应该是WORKSHEETS("Sheet10")