返回列表 上一主題 發帖

EXCEL 活頁簿SHEET1資料分至不同活頁簿

genes

帖子
45 
主題
1 
精華
0 
積分
51 
點名
0  
作業系統
windows 7 
軟體版本
office 2003 
閱讀權限
20 
註冊時間
2013-4-16 
最後登錄
2013-12-30 
1# 跳轉到 »
發表於 2013-5-5 00:34 | 顯示全部帖子
每一活頁簿是一個EXCEL獨立檔
  1. Sub SplitWorkbook()
  2. Dim ws As Worksheet
  3. Dim DisplayStatusBar As Boolean
  4. DisplayStatusBar = Application.DisplayStatusBar
  5. Application.DisplayStatusBar = True
  6. Application.ScreenUpdating = False
  7. Application.DisplayAlerts = False
  8. For Each ws In ThisWorkbook.Sheets
  9. Dim NewFileName As String
  10. Application.StatusBar = ThisWorkbook.Sheets.Count & “ Remaining Sheets”
  11. If ThisWorkbook.Sheets.Count <> 1 Then
  12. NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsm” ‘Macro _
  13. -Enabled
  14. ‘ NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsx” _
  15. ‘Not Macro-Enabled
  16. ws.Copy
  17. ActiveWorkbook.Sheets(1).Name = “Sheet1”
  18. ActiveWorkbook.SaveAs Filename:=NewFileName, _
  19. FileFormat:=xlOpenXMLWorkbookMacroEnabled
  20. ‘ ActiveWorkbook.SaveAs Filename:=NewFileName, _
  21. FileFormat:=xlOpenXMLWorkbook
  22. ActiveWorkbook.Close SaveChanges:=False
  23. Else
  24. NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsm”
  25. ‘ NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsx”
  26. ws.Name = “Sheet1”
  27. End If
  28. Next
  29. Application.DisplayAlerts = True
  30. Application.StatusBar = False
  31. Application.DisplayStatusBar = DisplayStatusBar
  32. Application.ScreenUpdating = True
  33. End Sub
複製代碼

TOP

        靜思自在 : 口說一句好話，如口出蓮花；口說一句壞話如口吐毒蛇。
返回列表 上一主題