拆表为簿

ddz79101

老师！有个工作簿，中间有许多表，我希望将其中的部分表独立存为簿，新簿名前加“新”，且不用 For Each sht In Worksheets遍历新式。请老师帮忙看看。谢谢

ykcbf1100

新写一个。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.23
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.path & ""
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> "说明" Then
   
7.             sht.Copy
   
8.             Set wb = ActiveWorkbook
   
9.             wb.SaveAs p & "新" & sht.Name, 56
   
10.             wb.Close
    
11.         End If
    
12.     Next
    
13.     Application.ScreenUpdating = True
    
14.     MsgBox "OK！"
    
15. End Sub
    
16. 
    

复制代码

ddz79101

ykcbf1100 发表于 2024-7-23 11:43
新写一个。。。

谢谢老师！运行中发现2个问题：1是运行不了，见图：
2是,我簿想用fou eash.因为我簿中不需导出的报表右8个（暂定），需要导出的是36个（12*3）（固定），用FOU EASH,太多了。老师可以用其他方法替代这逐个列明表名的方法吗？

Qs18

Sub qss()
Dim xb As Workbook, sht As Worksheet
pt = ThisWorkbook.path & "\"
For Each sht In Sheets
    If sht.Name <> "说明" Then
        sht.Copy
        Set xb = ActiveWorkbook
        xb.SaveAs pt & "新" & sht.Name & ".xls"
        xb.Close
    End If
Next
Set xb = Nothing
End Sub

Qs18

Sub qs()
Dim xb As Workbook
pt = ThisWorkbook.path & "\"
For i = 1 To Sheets.Count
T = Sheets(i).Name
    If T <> "说明" Then
        Sheets(i).Copy
        Set xb = ActiveWorkbook
        xb.SaveAs pt & "新" & T & ".xls"
        xb.Close
    End If
Next
Set xb = Nothing
End Sub

Qs18

试试..........

ykcbf1100

ddz79101 发表于 2024-7-23 11:58
谢谢老师！运行中发现2个问题：1是运行不了，见图：
2是,我簿想用fou eash.因为我簿中不需导出的报表右8 ...

改了，你再试一下。

ykcbf1100

改一下。。。

1. Sub ykcbf()  '//2024.7.23
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.path & ""
   
5.     For i = 1 To Sheets.Count
   
6.         Set sht = Sheets(i)
   
7.         If sht.Name <> "说明" Then
   
8.             sht.Copy
   
9.             Set wb = ActiveWorkbook
   
10.             wb.SaveAs Filename:=p & "新" & sht.Name, FileFormat:=56
    
11.             wb.Close
    
12.         End If
    
13.     Next
    
14.     Application.ScreenUpdating = True
    
15.     MsgBox "OK！"
    
16. End Sub
    
17. 
    

复制代码

limonet

关键字：openschema(20)