標題: [發問] 工作表另存時, 取消重覆存檔出錯 [打印本頁]

---

作者: missbb    時間: 2024-1-7 23:10     標題: 工作表另存時, 取消重覆存檔出錯

本帖最後由 missbb 於 2024-1-7 23:11 編輯

下列CODE, 我將工作表另存新檔, 但當存檔時有相同名稱的檔案, 我選擇不存檔, 程式仍會存檔在ACTIVE WORKBOOK的PATH, 和出現已"已經新增檔案".

我想如果選擇不重覆存檔, 直接退出程式, 顯示訊息"已經取消重覆存檔", 是如何改CODE呢? 謝謝![attach]37262[/attach][attach]37262[/attach]

1. Sub saveactivesheet2()
   
2. '目前工作表另存指定位置和檔按名稱
   
3. 
   
4. Application.ScreenUpdating = False
   
5. 'Application.DisplayAlerts = False
   
6. 
   
7. Dim currentworkbook As Workbook
   
8. Dim newworkbook As Workbook
   
9. Dim currentworksheet As Worksheet
   
10. Dim newworkbookname As String
    
11. Dim fPath As String
    
12. 
    
13. Set currentworkbook = ThisWorkbook
    
14. Set currentworksheet = ActiveSheet
    
15. 
    
16. newworkbookname = ActiveSheet.Range("S2").Value
    
17. fPath = ActiveSheet.Range("S3").Value
    
18. 
    
19. Set newworkbook = Workbooks.Add
    
20. currentworksheet.Copy before:=newworkbook.Sheets(1)
    
21. 
    
22. Range("A1:G100").Select
    
23.     Selection.Copy
    
24.     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    
25.         xlNone, SkipBlanks:=False, Transpose:=False
    
26.     Columns("H:Y").Select
    
27.     Application.CutCopyMode = False
    
28.     Selection.Delete Shift:=xlToLeft
    
29.     Range("A1").Select
    
30.     ActiveWorkbook.Save
    
31. 
    
32. On Error Resume Next
    
33. 
    
34. newworkbook.SaveAs Filename:=fPath & "\" & newworkbookname
    
35. 
    
36. newworkbook.Close
    
37. 
    
38. 'Since nothing changed on sheet, provide feedback to user
    
39.     MsgBox "已經新增檔案"
    
40. 
    
41. 
    
42. 
    
43. 
    
44. End Sub
    
45. 
    
46.    
    
47.    

複製代碼

---

作者: Andy2483    時間: 2024-1-8 08:46

回復 1# missbb


     If Dir(fPath & "\" & newworkbookname) <> "" Then Msgbox "已經取消重覆存檔"： Exit Sub

---

作者: missbb    時間: 2024-1-10 02:49

回復 2# Andy2483
想請較你新增的CODE應放在我的CODE那一個位置? 我放在ON ERROR RESUME NEXT之下, 即使不皇複存檔, 都是出現 MsgBox "已經新增檔案".

謝謝解答:D

---

作者: Andy2483    時間: 2024-1-10 08:27

回復 3# missbb


    謝謝論壇,謝謝前輩回復
以下是建議方案,請前輩參考

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim filename As String, fPath As String
filename = [S2]: fPath = [S3]: If Dir(fPath, vbDirectory) = "" Then MkDir fPath
If Dir(fPath & "\" & filename & ".xlsx") <> "" Then
   MsgBox "指定的 " & filename & ".xlsx 已經存在! 沒有執行存檔": Exit Sub
End If
ActiveSheet.Copy
[A1:G100].Value = [A1:G100].Value
[H:Y].Delete: [A1].Select
ActiveWorkbook.SaveAs filename:=fPath & "\" & filename & ".xlsx"
ActiveWorkbook.Close
MsgBox "已經新增檔案": ThisWorkbook.Activate
End Sub

---

作者: missbb    時間: 2024-1-11 07:56

謝謝，您的指導十分受用

---

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