[已解决]有多少张表就产生多少个Excel文件？

pandengyisun

如何通过VBA或者其它功能来实现如下功能：有多少张表就产生多少个Excel文件？

例：在Excel工作簿中有N个表，比如有人民币、美元、欧元……
那么最终结果是人民币.xlsx，美元.xlsx，欧元.xlsx……

最佳答案

月排行榜 / 总排行榜

QLZ0602

2011-8-24 14:38

Sub filesave()
Dim FilePath, SheetName
  FilePath = ActiveWorkbook.Path  '保存在相同文件夹下
  For i = 1 To Sheets.Count
    SheetName = Sheets(i).Name & ".XLS"
    Sheets(i).Copy
    Application.DisplayAlerts = False '覆盖文件时不提示
    ActiveWorkbook.SaveAs Filename:=FilePath & "\" & SheetName
    Windows(SheetName).Close
  Next i
End Sub

跳转到最佳答案楼层

adders

回复 pandengyisun 的帖子

Sub Split_WorkSheets()
    Application.ScreenUpdating = False
    Dim FilePath As String
    Dim DestWB As Workbook
    Dim FileName As String
   
    FilePath = ThisWorkbook.Path
    FilePath = FilePath & "\Temp\"    '假设新生文件存于源文件目录下新建的Temp子目录下
   
    For Each sht In ThisWorkbook.Sheets
        FileName = FilePath &  sht.Name
        
        Set DestWB = Workbooks.Add
        sht.Cells.Copy DestWB.Sheets(1).Cells
        DestWB.Close True, FileName
        Set DestWB = Nothing
    Next
   
    Application.ScreenUpdating = True
End Sub

QLZ0602

回复 pandengyisun 的帖子

Sub FileCopy()
'
' Macro1 Macro
' 宏由 000885 录制，时间: 2011-8-24
'
'
  Dim FilePath
  FilePath = ActiveWorkbook.Path  '保存在相同文件夹下
  For i = 1 To Sheets.Count
    Sheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=FilePath & "\" & i & ".xls"
    Windows(i & ".xls").Close
  Next i
End Sub

pandengyisun

回复 QLZ0602 的帖子

哥们，你做的有些靠谱，但文件名称不是表的名称。

pandengyisun

回复 adders 的帖子

朋友，你的程序运行不了。

QLZ0602

Sub FileCopy()
'
' Macro1 Macro
' 宏由 000885 录制，时间: 2011-8-24
'
'
  Dim FilePath
  FilePath = ActiveWorkbook.Path  '保存在相同文件夹下
  For i = 1 To Sheets.Count
    Sheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=FilePath & "\" &SHEET( i ).NAME & ".xls"
    Windows(i & ".xls").Close
  Next i
End Sub

QLZ0602

回复 pandengyisun 的帖子

' Macro1 Macro
' 宏由 000885 录制，时间: 2011-8-24
'
'
  Dim FilePath
  FilePath = ActiveWorkbook.Path  '保存在相同文件夹下
  For i = 1 To Sheets.Count
    Sheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=FilePath & "\" & SHEETS( i ).NAME & ".xls"
    Windows(i & ".xls").Close
  Next i
End Sub

pandengyisun

回复 QLZ0602 的帖子

你这个我也想过，但运行时会出现“下标越界”的现象。谢谢你。
如图：

QLZ0602

回复 pandengyisun 的帖子

Sub filesave()
Dim FilePath, SheetName
  FilePath = ActiveWorkbook.Path  '保存在相同文件夹下
  For i = 1 To Sheets.Count
    SheetName = Sheets(i).Name & ".XLS"
    Sheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=FilePath & "\" & SheetName
    Windows(SheetName).Close
  Next i
End Sub

之前没运行过, 增加了 SheetName = Sheets(i).Name & ".XLS"

QLZ0602

Sub filesave()
Dim FilePath, SheetName
  FilePath = ActiveWorkbook.Path  '保存在相同文件夹下
  For i = 1 To Sheets.Count
    SheetName = Sheets(i).Name & ".XLS"
    Sheets(i).Copy
    Application.DisplayAlerts = False '覆盖文件时不提示
    ActiveWorkbook.SaveAs Filename:=FilePath & "\" & SheetName
    Windows(SheetName).Close
  Next i
End Sub