【VBA】SaveAsでファイルに連番を追加し重複を防ぐ方法

nujonoa — Sun, 31 Jan 2021 01:15:16 +0000

VBAでSaveAsを使う際に、上書き保存するとそのままエクセルが落ちる現象が散見されました。

そこで、今回は、保存先フォルダに同一の名前が含まれるファイルがあった場合に、
連番を付けて登録するプログラムを作成しました。

【VBA】SaveAsでファイルに連番を追加し重複を防ぐ方法
プログラムの説明

【VBA】SaveAsでファイルに連番を追加し重複を防ぐ方法

SaveAsでファイルを保存する際に、
連番を追加し重複を防いで保存するプログラムを下記に示します。
※ダブルクリックでコピーできます。

Sub ファイルに連番を付けて保存()

Application.ScreenUpdating = False

'保存先フォルダを選択*開始**************************************
  MsgBox "保存先フォルダを選択"
  Dim folderPath As Variant
  With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "C:\Users\"
   If .Show = 0 Then
     MsgBox "キャンセルボタンをクリックしました。"
     Exit Sub
   End If
   folderPath = .SelectedItems(1)
  End With
'保存先フォルダを選択*終了**************************************

'保存名を入力*開始***************************************************
FileName = Application.InputBox(Prompt:="名前を入力してください。" & vbLf & vbLf, Type:=2, _
           Default:=ActiveSheet.Name & "_" & Year(Now) & Month(Now) & Day(Now))
   If FileName = False Then
     MsgBox "キャンセルボタンをクリックしました。"
     Exit Sub
   End If
'保存名を入力*終了***************************************************
   
'名前のダブり確認*開始***************************************************
        fn = "*" + FileName + "*"
        fnd = Dir(folderPath + "\" + fn, vbNormal)
        I = 0
        'ファイルがない場合
        If (fnd = "") Then
            GoTo CONTINUE1
        'ファイルがあった場合
        Else
        Do While fnd <> ""
           fnd = Dir '次のファイル
           I = I + 1
        Loop
        End If
        FileName = FileName & "(" & I & ")"

CONTINUE1:

'名前のダブり確認*終了***************************************************

FName = folderPath & "\" & FileName

'ファイルの保存***************************************************
    Worksheets.copy
    ActiveWorkbook.SaveAs _
    FileName:=FName, _
    FileFormat:=xlOpenXMLWorkbook
　'ファイルを閉じる
  Application.DisplayAlerts = False
    ActiveWorkbook.Close
  Application.DisplayAlerts = True

'ファイルの保存終了***************************************************


Application.ScreenUpdating = True

 
End Sub

プログラムの説明

プログラムの肝は、この部分になります。
Dir(ファイルパス)関数で、ファイルの存在を確認し、
もしファイルがあった場合、連番の数字を繰り上げていく形になります。

'名前のダブり確認*開始***************************************************
        fn = "*" + FileName + "*"
        fnd = Dir(folderPath + "\" + fn, vbNormal)
        I = 0
        'ファイルがない場合
        If (fnd = "") Then
            GoTo CONTINUE1
        'ファイルがあった場合
        Else
        Do While fnd <> ""
           fnd = Dir '次のファイル
           I = I + 1
        Loop
        End If
        FileName = FileName & "(" & I & ")"

CONTINUE1:

'名前のダブり確認*終了***************************************************

fnでファイル名を含むすべてのファイルを検索していますが、

        fn = "*" + FileName + ".Xls*"

とすると、エクセルのファイルだけを検出して避けることが可能です。

あとは、名前野田ぶりを無くしたので、ファイルを保存して終了です。
Worksheets.copy
の後に何もつけないと、新しいブックにコピーされますので、
SaveAsで保存して終了です。

FName = folderPath & "\" & FileName

'ファイルの保存***************************************************
    Worksheets.copy
    ActiveWorkbook.SaveAs _
    FileName:=FName, _
    FileFormat:=xlOpenXMLWorkbook
　'ファイルを閉じる
  Application.DisplayAlerts = False
    ActiveWorkbook.Close
  Application.DisplayAlerts = True

'ファイルの保存終了***************************************************

連番 | nujonoa_blog

【VBA】SaveAsでファイルに連番を追加し重複を防ぐ方法

【VBA】SaveAsでファイルに連番を追加し重複を防ぐ方法

プログラムの説明