謝謝論壇,謝謝前輩發表此主題與範例檔
後學藉此帖練習字典(檢查檔名重複),學習方案如下,請前輩參考
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 時間: 2023-12-5 13:48
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 時間: 2023-12-5 22:44
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)
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")
'↑令Z變數是 字典
T1 = "另存檔案路徑": T2 = "另存檔案名稱"
'↑令T1,T2變數是GJ; 雙引號之間的字串
For i = 1 To Worksheets.Count
'↑設順迴圈!令i從1到 此活頁簿工作表數量
Set F1 = Sheets(i).[1:1].Find(T1, Lookat:=xlWhole)
'↑令F1變數是 從第1列尋找 其內容與 "另存檔案路徑" 完全一樣的儲存格
Set F2 = Sheets(i).[2:2].Find(T2, Lookat:=xlWhole)
'↑令F2變數是 從第2列尋找 其內容與 "另存檔案名稱" 完全一樣的儲存格
If F1 Is Nothing Or F2 Is Nothing Then GoTo i01 Else T = F2(1, 2) & "/S"
'↑如果F1變數或 F2變數其中一個找不到!就跳到標示 i01的位置繼續執行,
'否則就令T變數是F2變數同一列右邊格的內容連接 "/S"所組成的新字串
If Z(T) <> "" Then MsgBox F2(1, 2) & " 檔名重複,請檢查": Exit Sub
'↑如果以T變數查Z字典 回傳item值不是空的!代表檔案名稱重複了,跳出提示,結束程式執行
Z(T) = F1(1, 2) & "": Set Z(F2(1, 2) & "") = Sheets(i): Z(F2(1, 2) & "/a") = F1.Address
'↑令T變數為key,item是 F1變數同一列右邊格的字串內容,納入Z字典中
'令F2變數同一列右邊格的字串內容為key,item是迴圈數所引號工作表
'令F2變數同一列右邊格的內容連接 "/a"所組成的字串為key,item是 F1變數的儲存格位址
i01: Next
For Each A In Z.KEYS
'↑設逐項迴圈!令A變數是Z字典的key之一
If Not IsObject(Z(A)) Then GoTo A01 Else T = Z(A & "/S")
'↑如果以A變數查Z字典回傳item不是物件!就跳到標示 A01位置繼續執行,
'否則就令T變數是 以A變數連接 "/S"所組成的字串查Z字典回傳值
Z(A).Copy: If Dir(T, vbDirectory) = "" Then MkDir T
'↑令A變數查Z字典回傳值(物件:工作表) 複製一份到新活頁簿
'如果T變數的資料夾不存在!就建立T(字串)變數的資料夾
With ActiveSheet.UsedRange: .Value = .Value: End With
'↑令此新活頁簿裡的該新工作表都計算成值(公式變成值)
Range(Z(A & "/a")).Resize(2, 2) = ""
'↑令檔案路徑與檔案名稱4格變成空格
With ActiveWorkbook: .SaveAs Filename:=T & "\" & A: .Close: End With
'↑令此新活頁簿儲存到指定路徑的檔名,之後關閉此新活頁簿
ThisWorkbook.Activate
'↑令程序回到本檔
A01: Next
End Sub作者: missbb 時間: 2023-12-13 22:53
