多張工作表另存活頁簿及抓住預設密碼 - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 多張工作表另存活頁簿及抓住預設密碼

返回列表下一主題上一主題發帖

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

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2013-11-25 10:37 | 顯示全部帖子

回復 1# missbb
試試看

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

帖子: 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-26 07:52 | 顯示全部帖子

回復 3# missbb

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2013-11-27 13:35 | 顯示全部帖子

回復 6# missbb

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2014-1-1 09:53 | 顯示全部帖子

本帖最後由 GBKEE 於 2014-1-1 10:15 編輯

回復 22# missbb

Option Explicit
Sub Ex2() ' Hsieh & GBKEE
Dim f$, fd$, fs$, A As Range, Wb As Workbook, AR()
Set Wb = ThisWorkbook ' 活頁簿 :程式碼所在的
fd = Wb.Path & "\" ' 存檔的路徑
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Wb.Sheets("PASSWORD")
For Each A In .Range(.[A2], .[A2].End(xlDown))
f = CStr(A)
fs = fd & f & ".xls"
AR = Wb.Sheets(f).UsedRange.Value
With Workbooks.Add(1)
.ActiveSheet.Range("A1").Resize(UBound(AR, 1), UBound(AR, 2)) = AR
' FileFormat:=xlExcel8 Excel 2003版本 56; xlExcel12 version 12, or 14, or 15 = Excel 2007, or 2010, or 2013.
.SaveAs Filename:=fs, Password:=CStr(A.Offset(, 1)), WriteResPassword:="" , FileFormat:=xlExcel8
.Close 0 ' 關閉 "D:\A123.xls" 活頁簿、"D:\B456.xls" 活頁簿。
End With ' 正式結束 (關閉)。
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

5^#

發表於 2014-1-1 10:23 | 顯示全部帖子

回復 26# missbb
2003測試需註解FileFormat:=xlExcel8
已更正取消註解 ' FileFormat:=xlExcel8

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2014-1-2 07:40 | 顯示全部帖子

回復 32# missbb
只要你認為活頁簿尚未保護時都可用的

'保護活頁簿使其不被修改。
ActiveWorkbook.Protect Password:="9999", structure:=True, Windows:=True

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

7^#

發表於 2014-1-4 17:46 | 顯示全部帖子

本帖最後由 GBKEE 於 2014-1-4 19:37 編輯

回復 35# missbb

Option Explicit
Sub Ex2()
Dim f$, fd$, fs$, A As Range, Wb As Workbook
Set Wb = ThisWorkbook ' 活頁簿 :程式碼所在的
fd = Wb.Path & "\" ' 存檔的路徑
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Wb.Sheets("PASSWORD")
For Each A In .Range(.[A2], .[A2].End(xlDown))
f = CStr(A)
fs = fd & f & ".xls"
Wb.Sheets(f).UsedRange.Copy '用COPY
With Workbooks.Add(1)
With .Sheets(1).Range("A1")
.PasteSpecial xlPasteValues '貼上值
.PasteSpecial xlPasteColumnWidths '貼上欄寬
.PasteSpecial xlPasteFormats '貼上格式
'第一重:保護工作表
.Parent.Protect Password:="9999", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
'第二重:保護活頁簿使其structure(結構:工作表不可刪增)。
.Protect Password:="9999", structure:=True, Windows:=False
' FileFormat:=xlExcel8 Excel 2003版本 56; xlExcel12 version 12, or 14, or 15 = Excel 2007, or 2010, or 2013.
'第三重: 限制使用者
.SaveAs Filename:=fs, Password:=CStr(A.Offset(, 1)), WriteResPassword:="" , FileFormat:=xlExcel8
.Close 0 ' 關閉 "D:\A123.xls" 活頁簿、"D:\B456.xls" 活頁簿。
End With ' 正式結束 (關閉)。
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 犯錯出懺悔心，才能清淨無煩惱。

返回列表下一主題上一主題