[發問] 多張工作表另存活頁簿及抓住預設密碼

missbb

[發問] 多張工作表另存活頁簿及抓住預設密碼
各位專家
本人正學習VBA, 請問如在活頁簿內有3張工作表
第1張工作表名為"PASSWORD",  已列出A123的PASSWORD在B1, B456的PASSWORD在B2
第2張工作表名為A123
第3張工作表名為B456

請教VBA寫法:
第2張工作表名為A123另存一個名為A123的活頁簿,. 並能取工作表名"PASSWORD"內的B1內的成為活頁簿密碼, 並只存文字的值及格式
第3張工作表名為B456另存一個名為B456的活頁簿,. 並能取工作表名"PASSWORD"內的B2內的成為活頁簿密碼, 並只存文字的值及格式

有労賜教!

GBKEE

回復 1# missbb
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Wb As Workbook, E As Variant, xPath As String, i As Integer
   
4.     Set Wb = ThisWorkbook           '活頁簿 :程式碼所在的
   
5.     'Set Wb = Workbooks(2)          '活頁簿 :第2個
   
6.     'Set Wb = Workbooks("a.xls")    '活頁簿 :指定名稱
   
7.     'Set Wb = ActiveWorkbook        '活頁簿 :作用中的
   
8.     xPath = Wb.Path & "\"                '存檔的路徑
   
9.     With Wb.Sheets("password")
   
10.         i = 1
    
11.         For Each E In Array("a123", "b456")
    
12.             Wb.Sheets(E).Copy
    
13.             ActiveWorkbook.Sheets(1).UsedRange.Value = ActiveWorkbook.Sheets(1).UsedRange.Value           '存文字的值及格式
    
14.             ActiveWorkbook.SaveAs Filename:=xPath & E & ".xls", Password:=.Cells(i, "b"), WriteResPassword:=""
    
15.             ActiveWorkbook.Close False
    
16.         Next
    
17.         i = i + 1
    
18.     End With
    
19. End Sub

複製代碼

missbb

回復 2# GBKEE



您好, 第一個檔案無問題, 但開啟第二個檔案時, 均說密碼不符. 已試驗兩次及用不同密碼也不行.:(  第二個檔案的密碼是存在B2儲存格內).

此外, 現在只是存兩個檔案, 但如果有20個檔案, 是否要將20個榴案的名字都輸入在程式內.
**For Each E In Array("a123", "b456"......."第20個檔")

多謝!

GBKEE

回復 3# missbb

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Wb As Workbook, E As Variant, xPath As String, I As Integer
   
4.     Set Wb = ThisWorkbook          '活頁簿 :程式碼所在的
   
5.     'Set Wb = Workbooks(2)          '活頁簿 :第2個
   
6.     'Set Wb = Workbooks("a.xls")  '活頁簿 :指定名稱
   
7.     'Set Wb = ActiveWorkbook      '活頁簿 :作用中的
   
8.     xPath = Wb.Path & "\"            '存檔的路徑
   
9.     With Wb.Sheets("password")
   
10.         '*********這活頁簿有20個工作表+"password"*************************************************
    
11.         For I = 1 To Wb.Sheets.Count - 1 'password 工作表 固定活頁簿中位置最後面(所有工作表的後面)
    
12.         ' For i = 2 To Wb.Sheets.Count     'password 工作表 固定活頁簿中位置最前面(第1個)
    
13.         '*********這活頁簿不只有20個工作表+"password" -> 活頁簿中20個工作表是連續在如(5-24)的索引位置**************
    
14.         ' For i = 5 To 24
    
15.         '********************************************************************************************
    
16.             Wb.Sheets(I).Copy
    
17.             ActiveWorkbook.Sheets(1).UsedRange.Value = ActiveWorkbook.Sheets(1).UsedRange.Value           '存文字的值及格式
    
18.             ActiveWorkbook.SaveAs Filename:=xPath & Wb.Sheets(I).Name & ".xls", Password:=Trim(.Cells(I, "b")), WriteResPassword:=""
    
19.                        '當 For i = 1  ->  Password:=Trim(.Cells(i, "b"))
    
20.                        '當 For i = 2  ->  Password:=Trim(.Cells(i - 1, "b"))
    
21.                        '當 For i = 3  ->  Password:=Trim(.Cells(i - WB.Sheets(3).Index + 1, "b"))
    
22.                        '當 For i = 4  ->  Password:=Trim(.Cells(i - WB.Sheets(4).Index + 1, "b"))
    
23.                         '密碼會錯誤,可能是前後有空白字元 ,Trim:消除前後空白字元 ->   Password:=Trim(.Cells(i, "b"))
    
24.             ActiveWorkbook.Close False
    
25.         Next
    
26.     End With
    
27. End Sub

複製代碼

Hsieh

回復 3# missbb

若工作表排序錯誤就容易出錯
建議將工作表對應密碼表寫再PASSWORD工作表(如圖)
直接取用工作表名稱對應密碼避免出錯
   

下載 (74.74 KB)

2013-11-26 13:48

1. Sub ex()
   
2. Dim f$, fd$, fs$, A As Range
   
3. fd = "D:\"
   
4. With Sheets("PASSWORD")
   
5. For Each A In .Range(.[A1], .[A1].End(xlDown))
   
6.    f = CStr(A)
   
7.    fs = fd & f & ".xls"
   
8.    Sheets(f).Copy
   
9.    With ActiveWorkbook
   
10.    .ActiveSheet.UsedRange = .ActiveSheet.UsedRange.Value
    
11.    .SaveAs Filename:=fs, Password:=CStr(A.Offset(, 1)), WriteResPassword:=""
    
12.    .Close 0
    
13.    End With
    
14. Next
    
15. End With
    
16. End Sub

複製代碼

missbb

回復 5# Hsieh

顯示偵錯COPY方法失敗 ->    Sheets(f).Copy

我作錯了甚麼?:Q

GBKEE

回復 6# missbb

1. Sub ex()
   
2. Dim f$, fd$, fs$, A As Range, Wb As Workbook
   
3.     Set Wb = ThisWorkbook          '活頁簿 :程式碼所在的
   
4.     'Set Wb = Workbooks(2)          '活頁簿 :第2個
   
5.     'Set Wb = Workbooks("a.xls")  '活頁簿 :指定名稱
   
6.     'Set Wb = ActiveWorkbook      '活頁簿 :作用中的
   
7.     fd = "D:\"
   
8.     With Wb.Sheets("PASSWORD")
   
9.         For Each A In .Range(.[A1], .[A1].End(xlDown))
   
10.         f = CStr(A)
    
11.         fs = fd & f & ".xls"
    
12.         Wb.Sheets(f).Copy
    
13.         '如有多個活頁簿啟時,且ActiveWorkbook,不是要複製工作表的活頁簿.
    
14.         '指定是哪一個活頁簿的工作表要複製
    
15.         With ActiveWorkbook
    
16.             .ActiveSheet.UsedRange = .ActiveSheet.UsedRange.Value
    
17.             .SaveAs Filename:=fs, Password:=CStr(A.Offset(, 1)), WriteResPassword:=""
    
18.             .Close 0
    
19.         End With
    
20.     Next
    
21.     End With
    
22. End Sub

複製代碼

ML089

回復 6# missbb


我測試是OK
可能是PASWORG工作表A欄內的名稱與工作名稱沒有對到

c_c_lai

回復 6# missbb
我亦測試過 Hsieh 版大的程式碼，一切正常無訛，
有可能是你在活頁簿間切換移轉時產生的問題。
其實 GBKEE、Hsieh 兩位版大的解題各有其不錯的詮釋。
我將它們予以加註，貼附如下，兩者間各有其巧妙之處，
很值得作為借鏡。

1. Option Explicit
   
2. 
   
3. Sub Ex()         '  GBKEE
   
4.     Dim Wb As Workbook, E As Variant, xPath As String, xi As Integer
   
5.    
   
6.     Set Wb = ThisWorkbook             '  活頁簿 :程式碼所在的
   
7.     xPath = Wb.Path & "\"             '  存檔的路徑；譬如： xPath : "D:\TXT\" : String
   
8.    
   
9.     With Wb.Sheets("password")
   
10.         For xi = 1 To Wb.Sheets.Count - 1   '  password 工作表 固定活頁簿中位置最後面(所有工作表的後面)
    
11.             Wb.Sheets(xi + 1).Copy          '  指定是哪一個活頁簿的工作表要複製
    
12.             '  Example:  Worksheets("Sheet1").Copy After:=Worksheets("Sheet3")
    
13.             '  This example copies Sheet1, placing the copy after Sheet3.
    
14.             '  Remarks:  If you don't specify either Before or After, Microsoft Excel creates a new workbook
    
15.             '            that contains the copied sheet.
    
16.             ActiveWorkbook.Sheets(1).UsedRange.Value = ActiveWorkbook.Sheets(1).UsedRange.Value  '  存文字的值及格式
    
17.                 '  FileFormat:=xlExcel8   Excel 2003版本 56; xlWorkbookDefault = Excel 2007, or 2010, or 2013.
    
18.            ActiveWorkbook.SaveAs Filename:=xPath & Wb.Sheets(xi + 1).Name & ".xls", Password:=Trim(.Cells(xi, "B")), WriteResPassword:="", FileFormat:=xlExcel8
    
19.             '   ActiveWorkbook.SaveAs Filename:=xPath & Wb.Sheets(xi + 1).Name & ".xlsx", Password:=Trim(.Cells(xi, "B")), WriteResPassword:="", FileFormat:=xlWorkbookDefault
    
20. 
    
21.             ActiveWorkbook.Close False     '  關閉 "D:\A123.xls" 活頁簿、"D:\B456.xls" 活頁簿。
    
22.         Next
    
23.     End With
    
24. End Sub

複製代碼

在 Hsieh 版大的程式碼中，GBKEE 增加了 Wb 的加強宣告，明確地指出活頁簿的屬性歸屬。

1. Sub Ex2()            '  Hsieh & GBKEE
   
2.     Dim f$, fd$, fs$, A As Range, Wb As Workbook
   
3.    
   
4.     Set Wb = ThisWorkbook             '  活頁簿 :程式碼所在的
   
5.     fd = Wb.Path & "\"                       '  存檔的路徑
   
6.     With Wb.Sheets("PASSWORD")
   
7.         For Each A In .Range(.[A1], .[A1].End(xlDown))
   
8.             '  A                                   : "A123" : Range/Range
   
9.             '  A                                   : "B456" : Range/Range
   
10.             '  Sheets("PASSWORD").[A1]             : "A123" : Variant/Object/Range
    
11.             '  Sheets("PASSWORD").[A1].End(xlDown) : "B456" : Variant/Object/Range
    
12.             f = CStr(A)
    
13.             fs = fd & f & ".xls"
    
14.             Wb.Sheets(f).Copy      '  指定是哪一個活頁簿的工作表要複製
    
15.             '  Sheets(f).Copy 執行過後，複製了一活頁簿，內有一名為 "A123" 之工作表單。
    
16.             '  ActiveWorkbook.Name           : "活頁簿1" : String
    
17.             '  ActiveWorkbook.Sheets(1).Name : "A123"    : Variant/String
    
18.             '  Sheets(f).Copy 執行過後，複製了一活頁簿，內有一名為 "B456" 之工作表單。
    
19.             '  ActiveWorkbook.Name           : "活頁簿2" : String
    
20.             '  ActiveWorkbook.Sheets(1).Name : "B456"    : Variant/String
    
21.             With ActiveWorkbook
    
22.                 .ActiveSheet.UsedRange = .ActiveSheet.UsedRange.Value
    
23.                 '  FileFormat:=xlExcel8   Excel 2003版本 56; xlExcel12  version 12, or 14, or 15 = Excel 2007, or 2010, or 2013.
    
24.                 .SaveAs Filename:=fs, Password:=CStr(A.Offset(, 1)), WriteResPassword:="", FileFormat:=xlExcel8
    
25.                 .Close 0       '  關閉 "D:\A123.xls" 活頁簿、"D:\B456.xls" 活頁簿。
    
26.             End With           '  正式結束 (關閉)。
    
27.         Next
    
28.     End With
    
29. End Sub

複製代碼

Hsieh

回復 6# missbb
程式碼只要是放在此檔案內，同一個EXCEL專案並無其他開啟的檔案
不需指定此活頁簿也應該可以執行
會出錯可能A欄的工作表名稱與要COPY的工作表名稱不符，但此類錯誤應該產生超出陣列索引錯誤
建議將你的檔案上傳，比較能夠了解錯誤點