【マクロ】同じファイル名がある場合メッセージを出すor指定の文字でしか名前を付けられないようにする

Question

以下のコードをご覧ください
●ファイル名前をインプットボックスに入力。指定の場所にエクセルファイルを保存します
ファイル名は　あいうえお11.xlsx　等です。11の部分だけ変更可能

この時、以下の１番、２番の条件を加える為のコードをご存じの方、教えて下さい

以下のコードを修正しても１から新しいコード作成でもどちらでもOKです
宜しくお願いします

１インプットボックスには半角数字２ケタしか入力できないようにする
⇒例：01 02 11

２保存先に同じファイルがあったら、再度、ファイル名のインプットボックス
入力へ戻るようにする


【コード】
Sub 名前を付けて別ファイル保存()
    
    
    Dim filename3 As String
    
    filename3 = InputBox("ファイル名、半角数字2ケタを入力して下さい")

    
    
    If filename3 <> "" Then
        
    ThisWorkbook.Sheets("Sheet1").Copy
     
     ActiveWorkbook.SaveAs "C:\Users\2020\OneDrive\マクロ\ブックからブックへコピー\" & "あいうえお" & filename3 & ".xlsx"
    
    
    End If


End Sub

amerikaumare · Accepted Answer

以下のコードを修正し、指定された条件を追加します。
条件
１．インプットボックスには半角数字2ケタしか入力できないようにする。
２．保存先に同じファイルがあったら、再度インプットボックス入力へ戻るようにする。
以下のように変更してみてください：

Sub 名前を付けて別ファイル保存()
    Dim filename3 As String
    Dim filepath As String
    Dim isValid As Boolean
    Do
        ' ファイル名の入力を促す
        filename3 = InputBox("ファイル名、半角数字2ケタを入力してください（例：01, 02, 11）")
        
        ' 半角数字2ケタかをチェック
        isValid = (Len(filename3) = 2 And IsNumeric(filename3))
        
        If Not isValid Then
            MsgBox "半角数字2ケタで入力してください。", vbExclamation
        Else
            ' 保存先のファイルパスを作成
            filepath = "C:\Users\2020\OneDrive\マクロ\ブックからブックへコピー\" & "あいうえお" & filename3 & ".xlsx"
            
            ' 同じファイル名が存在するか確認
            If Dir(filepath) <> "" Then
                MsgBox "同じファイル名が存在します。別の番号を入力してください。", vbExclamation
                isValid = False
            End If
        End If
        
    Loop Until isValid  ' 入力が正しい場合、ループを終了

' ファイルをコピーして保存
    ThisWorkbook.Sheets("Sheet1").Copy
    ActiveWorkbook.SaveAs filepath

End Sub

追加した内容
１．半角数字2ケタの入力チェック：入力が2ケタの数字でない場合、エラーメッセージを表示し再入力を促します。
２．ファイルの重複チェック：指定のフォルダに同じ名前のファイルが存在する場合、エラーメッセージを表示し再入力を促します。

tatsumaru77 · Answer

以下のようにしてください。

Sub 名前を付けて別ファイル保存()
    Dim filename3 As String
    Dim REG As Object
    Dim RegEx As Object
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Pattern = "^\d\d$"
    Dim path As String
    Do
        filename3 = InputBox("ファイル名、半角数字2ケタを入力して下さい")
        If filename3 = "" Then Exit Do
        If RegEx.Test(filename3) = True Then
            path = "C:\Users\2020\OneDrive\マクロ\ブックからブックへコピー\" & "あいうえお" & filename3 & ".xlsx"
            If Dir(path) = "" Then
                Exit Do
            Else
                MsgBox (path & " は既に存在します")
            End If
        Else
            MsgBox ("半角2桁の数字を入力してください")
        End If
    Loop
    If filename3 <> "" Then
        ThisWorkbook.Sheets("Sheet1").Copy
        ActiveWorkbook.SaveAs path
    End If
End Sub

【マクロ】同じファイル名がある場合メッセージを出すor指定の文字でしか名前を付けられないようにする

以下のコードを修正し、指定された条件を追加します。

以下のようにしてください。

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング