返回列表 上一主題 發帖

[發問] 工作表另存時, 取消重覆存檔出錯

missbb

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

[發問] 工作表另存時, 取消重覆存檔出錯

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

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

我想如果選擇不重覆存檔, 直接退出程式, 顯示訊息"已經取消重覆存檔", 是如何改CODE呢? 謝謝! TEST FILE SAVE.zip (18.08 KB)
  1. Sub saveactivesheet2()
  2. '目前工作表另存指定位置和檔按名稱

  4. Application.ScreenUpdating = False
  5. 'Application.DisplayAlerts = False

  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

  13. Set currentworkbook = ThisWorkbook
  14. Set currentworksheet = ActiveSheet

  16. newworkbookname = ActiveSheet.Range("S2").Value
  17. fPath = ActiveSheet.Range("S3").Value

  19. Set newworkbook = Workbooks.Add
  20. currentworksheet.Copy before:=newworkbook.Sheets(1)

  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

  32. On Error Resume Next

  34. newworkbook.SaveAs Filename:=fPath & "\" & newworkbookname

  36. newworkbook.Close

  38. 'Since nothing changed on sheet, provide feedback to user
  39.     MsgBox "已經新增檔案"




  44. End Sub

  46.    
  47.    
複製代碼
收藏 分享

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
2#
發表於 2024-1-8 08:46 | 只看該作者
回復 1# missbb


     If Dir(fPath & "\" & newworkbookname) <> "" Then Msgbox "已經取消重覆存檔"： Exit Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
3#
發表於 2024-1-10 02:49 | 只看該作者
回復 2# Andy2483
想請較你新增的CODE應放在我的CODE那一個位置? 我放在ON ERROR RESUME NEXT之下, 即使不皇複存檔, 都是出現 MsgBox "已經新增檔案".

謝謝解答:D

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
4#
發表於 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
5#
發表於 2024-1-11 07:56 | 只看該作者
謝謝，您的指導十分受用

TOP

        靜思自在 : 【生命在呼吸間】佛陀說：「生命在呼吸間。」人無法管住自己的生命，更無法擋住死期，讓自己永住人間。既然生命去來這麼無常，我們更應該好好地愛惜它、利用它、充實它，讓這無常、寶貴的生命，散發它真善美的光輝，映照出生命真正的價值。
返回列表 上一主題