[發問] 在資料夾中判斷有無相同檔名再儲存

s13030029

我的程式是要將我的工作表匯出成無巨集的活頁簿
所以我的程式會自動建立一個資料夾，再把我的檔案匯出至那個資料夾
但是我現在的程式沒辦法判斷資料夾裡有無重複的檔名
所以我希望能加入判斷有相同名稱就跳回inputbox重新輸入檔名
如果沒有相同檔名就直接儲存
希望能有高手幫忙~~~~~~~感激不盡~~~~~~~~

1. Sub 匯出製程記錄表()
   
2. 
   
3.     Titlename = ThisWorkbook.Sheets("製程檢查記錄表").Range("H4").Value
   
4.     Dim ylFolder As String
   
5.     ylFolder = ThisWorkbook.Path & "\" & Titlename & "記錄表" '指定資料夾
   
6.     If Dir(ylFolder, vbDirectory) = "" Then MkDir ylFolder
   
7. 
   
8.     Dim xPath As String
   
9.     xPath = Application.ActiveWorkbook.Path
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.    
    
13.     With ActiveSheet
    
14.        .Copy
    
15.        ActiveSheet.DrawingObjects.Delete
    
16.        X = InputBox("請輸入檔名!!", "另存新檔", Titlename & " " & "檢驗報告")
    
17.         If X <> "" Then
    
18.             Application.ActiveWorkbook.SaveAs Filename:=ylFolder & "\" & X, _
    
19.             FileFormat:=xlExcel8
    
20.             MsgBox "儲存成功！"
    
21.         ElseIf X = "" Then
    
22.             MsgBox "已取消儲存!!!"
    
23.         End If
    
24.        Application.ErrorCheckingOptions.BackgroundChecking = False
    
25.        Application.ActiveWorkbook.Close False
    
26.     End With
    
27.     Application.DisplayAlerts = True
    
28.     Application.ScreenUpdating = True
    
29.    
    
30. End Sub

複製代碼

判斷重複檔名.rar (28.11 KB)

下載次數: 3

2019-6-18 15:08

kim223824

你輸入的檔名可串上日期+時間就不會重複的問題 yyyymmddhhmm

kim223824

回復 1# s13030029

你輸入的檔名可串上日期+時間就不會重複的問題 yyyymmddhhmm

s13030029

回復 3# kim223824
因為我想要由使用者自訂名稱，所以才不加日期

s13030029

回復 1# s13030029
已解決~~
提供程式碼給大家參考

1. Sub 匯出製程記錄表()
   
2. 
   
3.     Titlename = ThisWorkbook.Sheets("製程檢查記錄表").Range("H4").Value
   
4.     Dim ylFolder As String
   
5.     ylFolder = ThisWorkbook.Path & "\" & Titlename & "記錄表" '指定資料夾
   
6.     If Dir(ylFolder, vbDirectory) = "" Then MkDir ylFolder
   
7.    
   
8.     Dim stFileName As String
   
9.     Dim xPath As String
   
10.     xPath = Application.ActiveWorkbook.Path
    
11.     Application.ScreenUpdating = False
    
12.     Application.DisplayAlerts = False
    
13.    
    
14.     With ActiveSheet
    
15.        .Copy
    
16.        ActiveSheet.DrawingObjects.Delete
    
17. XX:
    
18.        X = InputBox("請輸入檔名!!", "另存新檔", Titlename & " " & "檢驗報告")
    
19.        stFileName = ylFolder & "\" & X & ".xls"
    
20.        If X <> "" Then
    
21.             If Dir(stFileName) <> "" Then
    
22.                 MsgBox "已有相同檔名！"
    
23.                 GoTo XX
    
24.             Else
    
25.                 Application.ActiveWorkbook.SaveAs Filename:=ylFolder & "\" & X, _
    
26.                 FileFormat:=xlExcel8
    
27.                 MsgBox "儲存成功!"
    
28.             End If
    
29.         ElseIf X = "" Then
    
30.             MsgBox "已取消儲存!!!"
    
31.         End If
    
32.        Application.ErrorCheckingOptions.BackgroundChecking = False
    
33.        Application.ActiveWorkbook.Close False
    
34.     End With
    
35.     Application.DisplayAlerts = True
    
36.     Application.ScreenUpdating = True
    
37.    
    
38. End Sub

複製代碼

參考資料：https://analysistabs.com/excel-vba/check-file-exists-location-folder/