工作表另存新檔和以儲存格內容命名

missbb

想請教有一個活頁部, 要將第2張, 第3張和第4張WORKSHEET要另存為3個獨立WORKBOOK,  當中VLOOKUP資料轉為值, 格式不變.

檔案儲存路徑參照WORKSHEET內RANGE("G1")

活頁部名稱參照WORKSHEET內內RANGE("G2")

請多多幫忙:) 工作表另存檔案並以儲存格內容命名.zip (10.68 KB)

下載次數: 6

2023-12-5 00:06

Andy2483

回復 1# missbb


    謝謝論壇,謝謝前輩發表此主題與範例檔
後學藉此帖練習字典(檢查檔名重複),學習方案如下,請前輩參考
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim A, Z, i&, T$, T1$, T2$, F1 As Range, F2 As Range
Set Z = CreateObject("Scripting.Dictionary")
T1 = "另存檔案路徑": T2 = "另存檔案名稱"
For i = 1 To Worksheets.Count
   Set F1 = Sheets(i).[1:1].Find(T1, Lookat:=xlWhole)
   Set F2 = Sheets(i).[2:2].Find(T2, Lookat:=xlWhole)
   If F1 Is Nothing Or F2 Is Nothing Then GoTo i01 Else T = F2(1, 2) & "/S"
   If Z(T) <> "" Then MsgBox F2(1, 2) & " 檔名重複,請檢查": Exit Sub
   Z(T) = F1(1, 2) & "": Set Z(F2(1, 2) & "") = Sheets(i)
i01: Next
For Each A In Z.KEYS
   If Not IsObject(Z(A)) Then GoTo A01 Else T = Z(A & "/S")
   Z(A).Copy: If Dir(T, vbDirectory) = "" Then MkDir T
   With ActiveSheet.UsedRange: .Value = .Value: End With
   With ActiveWorkbook: .SaveAs Filename:=T & "\" & A: .Close: End With
   ThisWorkbook.Activate
A01: Next
End Sub

missbb

回復 2# Andy2483

多謝指道, :'(

missbb

回復 3# missbb


  想再多問, 如果在工作表設定了列印範圍(工作表1和2或有不同) , 另存新檔時不想顯示欄F 的路徑和檔案名字, 應在VBA CODE內那裡修改?

拜託指導

Andy2483

回復 4# missbb


    謝謝前輩回復,修改如下,請前輩參考
列印範圍(工作表1和2或有不同):經測試 原工作表列印範圍會帶到新複製的設定

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim A, Z, i&, T$, T1$, T2$, F1 As Range, F2 As Range
Set Z = CreateObject("Scripting.Dictionary")
T1 = "另存檔案路徑": T2 = "另存檔案名稱"
For i = 1 To Worksheets.Count
   Set F1 = Sheets(i).[1:1].Find(T1, Lookat:=xlWhole)
   Set F2 = Sheets(i).[2:2].Find(T2, Lookat:=xlWhole)
   If F1 Is Nothing Or F2 Is Nothing Then GoTo i01 Else T = F2(1, 2) & "/S"
   If Z(T) <> "" Then MsgBox F2(1, 2) & " 檔名重複,請檢查": Exit Sub
   Z(T) = F1(1, 2) & "": Set Z(F2(1, 2) & "") = Sheets(i): Z(F2(1, 2) & "/a") = F1.Address
i01: Next
For Each A In Z.KEYS
   If Not IsObject(Z(A)) Then GoTo A01 Else T = Z(A & "/S")
   Z(A).Copy: If Dir(T, vbDirectory) = "" Then MkDir T
   With ActiveSheet.UsedRange: .Value = .Value: End With
   Range(Z(A & "/a")).Resize(2, 2) = ""
   With ActiveWorkbook: .SaveAs Filename:=T & "\" & A: .Close: End With
   ThisWorkbook.Activate
A01: Next
End Sub

missbb

回復 5# Andy2483


    非常感謝!

missbb

回復  missbb


    謝謝前輩回復,修改如下,請前輩參考
列印範圍(工作表1和2或有不同):經測試 原工作表 ...
Andy2483 發表於 2023-12-5 14:16

你好 , 一直在試用 , 現時可是將全部工作表2,工作表3和工作表4另存為新的WORKBOOK.  但如果只要工作表2和工作表4另存WORKSBOOK (又或是只另存工作表4等不同情況), 可否用INPUT BOX輸入來制作?  :(

Andy2483

回復 7# missbb


    謝謝前輩再指教
1.部分另存的意義為何?
另存的目標資料夾位置都一樣,即使是部分另存,這些另存檔還是混同一資料夾裡,取用一樣需要在檔案總管挑選,所以部分另存會變得意義不大,這是會有此疑問的原因

2.或說明這些另存的用途.另存頻率....等

3.如果只是列印後另存,可參考以下鏈結帖
https://forum.twbts.com/viewthre ... mp;page=2#pid122046

missbb

回復 8# Andy2483


    因為工作需要，未必每次都要另存所有工作表。我會參照你提供的資料再試，非常感謝:)

singo1232001

回復 9# missbb


    Sub 同資料夾導出()

Set outSh = ActiveSheet
Set myBook = ThisWorkbook
        
Filename = outSh.[G2].Value & " " & Format(Now, "yyyyMMdd_HHnnss") & ".xlsx"
' 設定檔案保存路徑（更改為所需路徑）
filePath = myBook.Path & "\" & Filename

outSh.Copy
Set NewWorkbook = ActiveWorkbook
    ' 保存新工作簿
NewWorkbook.SaveAs Filename:=filePath
End Sub


Sub G1G2另存路徑導出()

Set outSh = ActiveSheet
Set myBook = ThisWorkbook
        
Filename = outSh.[G2].Value & " " & Format(Now, "yyyyMMdd_HHnnss") & ".xlsx"
' 設定檔案保存路徑（更改為所需路徑）
filePath = Range("G1").Value & "\" & Filename

outSh.Copy
Set NewWorkbook = ActiveWorkbook
    ' 保存新工作簿
NewWorkbook.SaveAs Filename:=filePath
End Sub



Sub 資料選擇器路徑導出()


Set fd = Excel.Application.FileDialog(msoFileDialogFolderPicker)  '設定選取檔案功能
fd.InitialFileName = Excel.ActiveWorkbook.Path  '設定預設目錄
fd.Show '顯示對話框
If fd.SelectedItems.Count = 0 Then Exit Sub
Set myBook = ThisWorkbook
Set outSh = ActiveSheet
myPath = fd.SelectedItems(1)

Filename = outSh.[G2].Value & " " & Format(Now, "yyyyMMdd_HHnnss") & ".xlsx"
' 設定檔案保存路徑（更改為所需路徑）
filePath = Range("G1").Value & "\" & Filename

outSh.Copy
Set NewWorkbook = ActiveWorkbook
    ' 保存新工作簿
NewWorkbook.SaveAs Filename:=filePath
End Sub