Board logo

標題: [發問] 在資料夾中判斷有無相同檔名再儲存 [打印本頁]

作者: s13030029    時間: 2019-6-18 15:09     標題: 在資料夾中判斷有無相同檔名再儲存

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

  2.     Titlename = ThisWorkbook.Sheets("製程檢查記錄表").Range("H4").Value
  3.     Dim ylFolder As String
  4.     ylFolder = ThisWorkbook.Path & "\" & Titlename & "記錄表" '指定資料夾
  5.     If Dir(ylFolder, vbDirectory) = "" Then MkDir ylFolder

  6.     Dim xPath As String
  7.     xPath = Application.ActiveWorkbook.Path
  8.     Application.ScreenUpdating = False
  9.     Application.DisplayAlerts = False
  10.    
  11.     With ActiveSheet
  12.        .Copy
  13.        ActiveSheet.DrawingObjects.Delete
  14.        X = InputBox("請輸入檔名!!", "另存新檔", Titlename & " " & "檢驗報告")
  15.         If X <> "" Then
  16.             Application.ActiveWorkbook.SaveAs Filename:=ylFolder & "\" & X, _
  17.             FileFormat:=xlExcel8
  18.             MsgBox "儲存成功!"
  19.         ElseIf X = "" Then
  20.             MsgBox "已取消儲存!!!"
  21.         End If
  22.        Application.ErrorCheckingOptions.BackgroundChecking = False
  23.        Application.ActiveWorkbook.Close False
  24.     End With
  25.     Application.DisplayAlerts = True
  26.     Application.ScreenUpdating = True
  27.    
  28. End Sub
複製代碼
[attach]30895[/attach]
作者: kim223824    時間: 2019-6-18 16:02

你輸入的檔名可串上日期+時間就不會重複的問題 yyyymmddhhmm
作者: kim223824    時間: 2019-6-18 16:04

回復 1# s13030029

你輸入的檔名可串上日期+時間就不會重複的問題 yyyymmddhhmm
作者: s13030029    時間: 2019-6-18 16:34

回復 3# kim223824
因為我想要由使用者自訂名稱,所以才不加日期
作者: s13030029    時間: 2019-6-18 16:38

回復 1# s13030029
已解決~~
提供程式碼給大家參考
  1. Sub 匯出製程記錄表()

  2.     Titlename = ThisWorkbook.Sheets("製程檢查記錄表").Range("H4").Value
  3.     Dim ylFolder As String
  4.     ylFolder = ThisWorkbook.Path & "\" & Titlename & "記錄表" '指定資料夾
  5.     If Dir(ylFolder, vbDirectory) = "" Then MkDir ylFolder
  6.    
  7.     Dim stFileName As String
  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. XX:
  17.        X = InputBox("請輸入檔名!!", "另存新檔", Titlename & " " & "檢驗報告")
  18.        stFileName = ylFolder & "\" & X & ".xls"
  19.        If X <> "" Then
  20.             If Dir(stFileName) <> "" Then
  21.                 MsgBox "已有相同檔名!"
  22.                 GoTo XX
  23.             Else
  24.                 Application.ActiveWorkbook.SaveAs Filename:=ylFolder & "\" & X, _
  25.                 FileFormat:=xlExcel8
  26.                 MsgBox "儲存成功!"
  27.             End If
  28.         ElseIf X = "" Then
  29.             MsgBox "已取消儲存!!!"
  30.         End If
  31.        Application.ErrorCheckingOptions.BackgroundChecking = False
  32.        Application.ActiveWorkbook.Close False
  33.     End With
  34.     Application.DisplayAlerts = True
  35.     Application.ScreenUpdating = True
  36.    
  37. End Sub
複製代碼
參考資料:https://analysistabs.com/excel-vba/check-file-exists-location-folder/




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