- 帖子
- 1425
- 主題
- 40
- 精華
- 0
- 積分
- 1449
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-4-16
|
12#
發表於 2023-12-13 08:09
| 只看該作者
本帖最後由 Andy2483 於 2023-12-13 16:21 編輯
回復 11# missbb
謝謝前輩再回復,一起學習
後學藉此帖做複習心得與添加新需求,學習方案如下,請前輩參考
表格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格變成空格
'將另存新檔的範圍 , 指定在A1 至E30 ??
'因為需求是要保留原來格式,所以以複製工作表到新活頁簿,再刪除不要的範圍即可
ActiveSheet.UsedRange.Offset([A1:E30].Rows.Count, 0).EntireRow.Delete
'↑令指定保留的範圍以下的列 刪除
ActiveSheet.UsedRange.Offset(0, [A1:E30].Columns.Count).EntireColumn.Delete
'↑令指定保留的範圍右側欄 刪除
With ActiveWorkbook: .SaveAs Filename:=T & "\" & A: .Close: End With
'↑令此新活頁簿儲存到指定路徑的檔名,之後關閉此新活頁簿
ThisWorkbook.Activate
'↑令程序回到本檔
A01: Next
End Sub |
|
