標題: [發問] 存檔時自動備份檔案並轉為.xlsx格式 [打印本頁]

---

作者: msmplay    時間: 2016-8-20 01:19     標題: 存檔時自動備份檔案並轉為.xlsx格式

不好意思想請問一下，我想打開一份有巨集的excel檔後，在檔案儲存時能同步自動備份檔案到「備份」資料夾
且檔案格式要轉為.xlsx，但我測試以下代碼後，自動備份檔案到「備份」資料夾有成功，但打開檔案時卻出現以下視窗而且完全打不開

[attach]24985[/attach]

想請問以下代碼是否有誤或該如何修正呢!?非常感謝~~~~~~~

thisworkbook，代碼：
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Dim mypath As String, fname As String
fname = "自動備份" & Format(Date, "yymmdd") & ".xlsx"
mypath = ThisWorkbook.Path & "/備份/"
ThisWorkbook.SaveCopyAs mypath & fname
End Sub

---

作者: lpk187    時間: 2016-8-20 14:17

回復 1# msmplay

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2. Dim mypath As String, fname As String
   
3. fname = "自動備份" & Format(Date, "yymmdd") & ".xlsx"
   
4. mypath = ThisWorkbook.Path & "\備份\"
   
5. ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
   
6. End Sub

複製代碼

---

作者: zyzzyva    時間: 2016-8-21 00:21

回復 1# msmplay
SaveCopyAs好像沒辦法指定格式。沒想到更好的辦法，這個試試看。

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     On Error Resume Next
   
3.     Dim mypath As String, fname As String
   
4.    
   
5.     If Me.Saved = True Then
   
6.         fname = "自動備份" & Format(Date, "yymmdd")
   
7.         mypath = ThisWorkbook.Path & "/備份/"
   
8.         ThisWorkbook.SaveCopyAs mypath & fname & ".xlsm"
   
9.         
   
10.         Workbooks.Open (mypath & fname & ".xlsm")
    
11.         Application.DisplayAlerts = False
    
12.         ActiveWorkbook.SaveAs mypath & fname, FileFormat:=51
    
13.         Application.DisplayAlerts = True
    
14.         ActiveWorkbook.Close
    
15.         Kill (mypath & fname & ".xlsm")
    
16.     End If
    
17.    
    
18. End Sub

複製代碼

---

作者: msmplay    時間: 2016-8-21 00:28

回復 2# lpk187

   l大~~~~非常感謝幫忙，不過小妹測試之後原檔出現以下錯誤訊息，可以再請您幫忙看看嗎~~~~
[attach]24989[/attach]

[attach]24990[/attach]

[attach]24991[/attach]

---

作者: zyzzyva    時間: 2016-8-21 00:38

本帖最後由 zyzzyva 於 2016-8-21 00:40 編輯

3F的code有點bug，一定要先存檔再關閉才有用，如果是在對話視窗出來再按「是」存檔就不會作用。
應該是事件觸發先後的問題，要再修改一下。

---

作者: msmplay    時間: 2016-8-21 00:38

回復 3# zyzzyva

z大~~~~~您又出手相助了!!!非常感謝喔~~~~~
不過測試之後，雖然已經按過存檔，但只要關閉檔案時還是會再出現一次以下的訊息視窗，請問是否可跳過此對話視窗呢!?

[attach]24992[/attach]

---

作者: zyzzyva    時間: 2016-8-21 00:54

本帖最後由 zyzzyva 於 2016-8-21 00:56 編輯

回復 6# msmplay
怪怪，我用空白的測沒有這個問題，可以先在kill下一行加個ActiveWorkbook.Save，bug明天有空再研究。

---

作者: lpk187    時間: 2016-8-21 06:59

回復 4# msmplay

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2. Dim mypath As String, fname As String
   
3. fname = "自動備份" & Format(Date, "yymmdd") & ".xlsx"
   
4. mypath = ThisWorkbook.Path & "\備份\"
   
5. Application.DisplayAlerts = False '關閉系統警告訊息
   
6. ThisWorkbook.Save '要儲存自身檔案，請自行選擇要不要儲存
   
7. ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
   
8. Application.DisplayAlerts = True '開啟系統警告訊息
   
9. End Sub

複製代碼

---

作者: c_c_lai    時間: 2016-8-21 07:08

回復 6# msmplay
原因非常明顯，有巨集的的活頁簿檔案，
如存成 .xlsx 型態，其巨集會隨之消失的。

---

作者: zyzzyva    時間: 2016-8-21 09:50

回復 6# msmplay
後來想了一下，如果沒有一定要用SaveCopyAs的原因，用l大的方式直接SaveAs比較好。
不過最好還是加個if判斷，不然如果關閉的時候選否，備份還是會執行，原來正確的備份就被蓋掉了。
拿網路上跟l大的code組合改了一下，您再參考看看。

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     Dim mypath As String, fname As String
   
3. 
   
4.     If Not Me.Saved Then
   
5.         Msg = "Do you want to save the changes you made to "
   
6.         Msg = Msg & Me.Name & "?"
   
7.         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
   
8.         Select Case Ans
   
9.             Case vbYes
   
10.                 Me.Save
    
11.             Case vbNo
    
12.                 Me.Saved = False
    
13.             Case vbCancel
    
14.                 Cancel = True
    
15.                 Exit Sub
    
16.           End Select
    
17.     End If
    
18.    
    
19.     If Me.Saved Then
    
20.         Application.DisplayAlerts = False '關閉系統警告訊息
    
21.         fname = "自動備份" & Format(Date, "yymmdd") & ".xlsx"
    
22.         mypath = ThisWorkbook.Path & "\備份\"
    
23.         'ThisWorkbook.Save '要儲存自身檔案，請自行選擇要不要儲存
    
24.         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
    
25.         Application.DisplayAlerts = True '開啟系統警告訊息
    
26.     Else
    
27.         Me.Saved = True
    
28.     End If
    
29.       
    
30. End Sub

複製代碼

---

作者: msmplay    時間: 2016-8-21 12:06

回復 10# zyzzyva


   z大~~~~測試已成功，真的超級感謝的呦

---

作者: msmplay    時間: 2016-11-2 19:59

本帖最後由 msmplay 於 2016-11-2 20:02 編輯

回復 10# zyzzyva


   z大~~可以請教兩個延伸的問題嗎?
就是如果自動備份位置希望改為檔案的上層資料夾，該如何修改呢?
例如:檔案 放於 C:\Users\Downloads\測試，希望自動備份檔案於 C:\Users\Downloads


另外如果希望自動備份的檔案固定存為唯讀檔，又該如何修改呢?
例如: 測試檔.xlsm 存檔時自動備份為 測試檔.xlsx(唯讀)

---

作者: zyzzyva    時間: 2016-11-2 21:21

回復 12# msmplay
測試看看。(不要放在根目錄如C:\下)

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     Dim mypath As String, fname As String
   
3. 
   
4.     If Not Me.Saved Then
   
5.         Msg = "Do you want to save the changes you made to "
   
6.         Msg = Msg & Me.Name & "?"
   
7.         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
   
8.         Select Case Ans
   
9.             Case vbYes
   
10.                 Me.Save
    
11.             Case vbNo
    
12.                 Me.Saved = False
    
13.             Case vbCancel
    
14.                 Cancel = True
    
15.                 Exit Sub
    
16.           End Select
    
17.     End If
    
18.    
    
19.     If Me.Saved Then
    
20.         Application.DisplayAlerts = False '關閉系統警告訊息
    
21.         fname = "\自動備份" & Format(Date, "yymmdd") & ".xlsx"
    
22.         mypath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)
    
23.         'ThisWorkbook.Save '要儲存自身檔案，請自行選擇要不要儲存
    
24.         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
    
25.         Application.DisplayAlerts = True '開啟系統警告訊息
    
26.     Else
    
27.         Me.Saved = True
    
28.     End If
    
29.    
    
30.     Targetfile = mypath & fname
    
31. 
    
32.     If GetAttr(Targetfile) Then
    
33.         SetAttr Targetfile, vbReadOnly
    
34.     End If
    
35.       
    
36. End Sub

複製代碼

---

作者: msmplay    時間: 2016-11-2 22:23

本帖最後由 msmplay 於 2016-11-2 22:33 編輯

回復 13# zyzzyva

   z大~~~~~測試後，發現第一次存檔成功，但第二次要再存檔就會出現以下錯誤，是不是因為唯讀檔無法覆蓋問題呢??

[attach]25709[/attach][attach]25708[/attach]

---

作者: zyzzyva    時間: 2016-11-3 08:49

回復 14# msmplay
對阿，是唯讀屬性的問題。如果希望之後還可以直接存檔，可能存檔前要加個檢查，如果屬性已經是唯讀，就改回一般(vbNormal)

---

作者: msmplay    時間: 2016-11-3 09:00

回復 15# zyzzyva

z大~~~~那請問可以存檔即覆蓋舊檔嗎？也就是無論如何，原始檔只要存檔就是要覆蓋備份唯讀檔，可以醬嗎？又該如何修改呢？真的非常感謝~~~~~~

---

作者: zyzzyva    時間: 2016-11-3 09:24

回復 16# msmplay
改了一下，應該可以，再試試看。

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     Dim mypath As String, fname As String
   
3.    
   
4.     fname = "\自動備份" & Format(Date, "yymmdd") & ".xlsx"
   
5.     mypath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)
   
6.     Targetfile = mypath & fname
   
7.    
   
8. 
   
9.     If Not Me.Saved Then
   
10.         Msg = "Do you want to save the changes you made to "
    
11.         Msg = Msg & Me.Name & "?"
    
12.         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
    
13.         Select Case Ans
    
14.             Case vbYes
    
15.                 Me.Save
    
16.             Case vbNo
    
17.                 Me.Saved = False
    
18.             Case vbCancel
    
19.                 Cancel = True
    
20.                 Exit Sub
    
21.           End Select
    
22.     End If
    
23.    
    
24.     If Me.Saved Then
    
25.         Application.DisplayAlerts = False '關閉系統警告訊息
    
26.         'ThisWorkbook.Save '要儲存自身檔案，請自行選擇要不要儲存
    
27.         If Dir(Targetfile) <> "" Then
    
28.             If GetAttr(Targetfile) And vbReadOnly Then
    
29.                 SetAttr Targetfile, vbNormal
    
30.             End If
    
31.         End If
    
32.         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
    
33.         Application.DisplayAlerts = True '開啟系統警告訊息
    
34.     Else
    
35.         Me.Saved = True
    
36.     End If
    
37. 
    
38.     If Dir(Targetfile) <> "" Then
    
39.         If GetAttr(Targetfile) Then
    
40.             SetAttr Targetfile, vbReadOnly
    
41.         End If
    
42.     End If
    
43.       
    
44. End Sub

複製代碼

---

作者: msmplay    時間: 2016-11-3 12:44

本帖最後由 msmplay 於 2016-11-3 12:45 編輯

回復 17# zyzzyva

z大~~真的可以了耶！謝謝你*^O^*

---

作者: msmplay    時間: 2016-11-5 00:36

回復 17# zyzzyva

z大~~~~結果公司又要將備份檔改放於像之前寫的那樣，放在檔案下一層備份資料夾內mypath = ThisWorkbook.Path & "\備份\"


結果我嘗試改了一下但都不對，可以再麻煩您嗎~~~~
紅色是我自己亂改的

• Private Sub Workbook_BeforeClose(Cancel As Boolean)
•     Dim mypath As String, fname As String
•     fname = "\自動備份" & Format(Date, "yymmdd") & ".xlsx"
•     mypath = ThisWorkbook.Path & "\備份\"
•     Targetfile = mypath & fname
•     If Not Me.Saved Then
•         Msg = "Do you want to save the changes you made to "
•         Msg = Msg & Me.Name & "?"
•         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
•         Select Case Ans
•             Case vbYes
•                 Me.Save
•             Case vbNo
•                 Me.Saved = False
•             Case vbCancel
•                 Cancel = True
•                 Exit Sub
•           End Select
•     End If
•     If Me.Saved Then
•         Application.DisplayAlerts = False '關閉系統警告訊息
•         'ThisWorkbook.Save '要儲存自身檔案，請自行選擇要不要儲存
•         If Dir(Targetfile) <> "" Then
•             If GetAttr(Targetfile) And vbReadOnly Then
•                 SetAttr Targetfile, vbNormal
•             End If
•         End If
•         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
•         Application.DisplayAlerts = True '開啟系統警告訊息
•     Else
•         Me.Saved = True
•     End If
•     If Dir(Targetfile) <> "" Then
•         If GetAttr(Targetfile) Then
•             SetAttr Targetfile, vbReadOnly
•         End If
•     End If
• End Sub

---

作者: zyzzyva    時間: 2016-11-6 16:06

回復 19# msmplay
應該只是多了一個\，改成mypath = ThisWorkbook.Path & "\備份"試試看。

---

作者: msmplay    時間: 2016-11-6 16:19

回復 20# zyzzyva


   哈~~~~~~怎麼辦我好笨喔!!!

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)