1234
返回列表 上一主題 發帖

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

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-11-24 20:11 | 只看該作者

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

[發問] 多張工作表另存活頁簿及抓住預設密碼
各位專家
本人正學習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

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2013-11-25 10:37 | 只看該作者
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
3#
發表於 2013-11-25 21:23 | 只看該作者
回復 2# GBKEE



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

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

多謝!

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2013-11-26 07:52 | 只看該作者
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
256  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-26 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2013-11-26 13:49 | 只看該作者
回復 3# missbb

若工作表排序錯誤就容易出錯
建議將工作表對應密碼表寫再PASSWORD工作表(如圖)
直接取用工作表名稱對應密碼避免出錯
   
  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
複製代碼
學海無涯_不恥下問

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
6#
發表於 2013-11-27 13:18 | 只看該作者
回復 5# Hsieh

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

我作錯了甚麼?:Q

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2013-11-27 13:35 | 只看該作者
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
8#
發表於 2013-11-27 23:28 | 只看該作者
回復 6# missbb


我測試是OK
可能是PASWORG工作表A欄內的名稱與工作名稱沒有對到
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
9#
發表於 2013-11-28 08:24 | 只看該作者
本帖最後由 c_c_lai 於 2013-11-28 08:30 編輯

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

  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

  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
複製代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
256  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-26 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
10#
發表於 2013-11-28 09:36 | 只看該作者
回復 6# missbb
程式碼只要是放在此檔案內，同一個EXCEL專案並無其他開啟的檔案
不需指定此活頁簿也應該可以執行
會出錯可能A欄的工作表名稱與要COPY的工作表名稱不符，但此類錯誤應該產生超出陣列索引錯誤
建議將你的檔案上傳，比較能夠了解錯誤點
學海無涯_不恥下問

TOP

        靜思自在 : 有多少力量就做多少事，不要心存等待，等待才會落空。
1234
返回列表 上一主題