VBA問題請教_每張工作表存成個別檔案延伸問題?

2020-10-22 12:16 pm
先前在版上看到下方的解答,可以將Excel活頁簿中多個分頁分別另存成單獨的檔案,現在想要增加下述條件,能否幫忙改寫?

(1)"把作用中的活頁簿的第i個工作表複製到另一個新開啟的活頁簿"後 要(中斷連結)

(2)"把新活頁簿儲存到指定路徑 , 且檔名與工作表名稱相同"改成
"把新活頁簿儲存到指定路徑 , 且檔名與原始檔案名稱相同再加上工作表名稱"


Sub 切割活頁簿() 

source_window_name = ActiveWindow.Caption

source_path_name = ActiveWorkbook.Path

    '先把現在準備分割的原始檔案的視窗名稱及路徑記錄下來

target_path = source_path_name & "\" & Left(source_window_name, Len(source_window_name) - 4)

MkDir target_path

    '建立準備儲存切割完成檔案的新資料夾

For i = 1 To ActiveWorkbook.Sheets.Count

    '使用迴圈 , 執行次數是作用中的活頁簿的工作表數量

    ActiveWorkbook.Sheets(i).Copy

    '把作用中的活頁簿的第i個工作表複製到另一個新開啟的活頁簿

    ActiveWorkbook.SaveAs target_path & "\" & ActiveSheet.Name

    '需注意這裡的ActiveWorkbook已經是新的活頁簿了

    '把新活頁簿儲存到指定路徑 , 且檔名與工作表名稱相同

    ActiveWorkbook.Close

    '關閉已經儲存的新活頁簿

    Windows(source_window_name).Activate

    '將作用視窗切換回原始檔案

Next

End Sub

回答 (1)

2020-10-24 9:49 pm
可以使用錄製巨集再來修改參數

Sub test()
Dim i As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sht = ActiveWorkbook.Name
For i = 1 To ActiveWorkbook.Sheets.Count
    Sheets(i).Select
    Shx = ActiveSheet.Name
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False ''只貼上值就沒有連結
    Range("A1").Select
    Sheets(1).Name = Shx
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sht & "_" & Shx & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close False
    Range("A1").Select
Next
Application.ScreenUpdating = True
End Sub


收錄日期: 2021-05-03 06:54:26
原文連結 [永久失效]:
https://hk.answers.yahoo.com/question/index?qid=20201022041654AAtTNnY

檢視 Wayback Machine 備份