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

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

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

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

TEST FILE SAVE.zip (18.08 KB)

Sub saveactivesheet2()
'目前工作表另存指定位置和檔按名稱
Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim currentworkbook As Workbook
Dim newworkbook As Workbook
Dim currentworksheet As Worksheet
Dim newworkbookname As String
Dim fPath As String
Set currentworkbook = ThisWorkbook
Set currentworksheet = ActiveSheet
newworkbookname = ActiveSheet.Range("S2").Value
fPath = ActiveSheet.Range("S3").Value
Set newworkbook = Workbooks.Add
currentworksheet.Copy before:=newworkbook.Sheets(1)
Range("A1:G100").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Columns("H:Y").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
ActiveWorkbook.Save
On Error Resume Next
newworkbook.SaveAs Filename:=fPath & "\" & newworkbookname
newworkbook.Close
'Since nothing changed on sheet, provide feedback to user
MsgBox "已經新增檔案"
End Sub

複製代碼

樓主熱帖

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

中學生 Rank: 2

帖子: 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

中學生 Rank: 2

帖子: 216
主題: 71
精華: 0
積分: 292
點名: 0
作業系統: window xp
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-27
最後登錄: 2024-9-28

5^#

發表於 2024-1-11 07:56 | 只看該作者

謝謝，您的指導十分受用

TOP