ファイルを保存する場所の指定3

Sub 追加2SaveSelectedSheetsToNewWorkbook()
    Dim wsDate As Worksheet
    Dim targetDate As Date
    Dim formattedDate As String
    Dim yearFolder As String
    Dim savePath As String
    Dim newWb As Workbook
    Dim currentWb As Workbook
    Dim sheetNames As Variant
    Dim i As Integer
    Dim fileExists As Boolean
    Dim response As VbMsgBoxResult
    Dim altSavePath As Variant ' Variant にしてキャンセル時を処理

    ' 初期設定
    Set currentWb = ThisWorkbook
    Set wsDate = currentWb.Sheets("CSV取り込み")

    ' セルA2の日付を取得
    On Error GoTo DateError
    targetDate = wsDate.Range("A2").value
    On Error GoTo 0

    formattedDate = Format(targetDate, "yyyymmdd")

    ' 保存先フォルダ（年フォルダ）
    yearFolder = "C:\Users\matsu\Desktop\提出用\" & Year(targetDate)
    If Dir(yearFolder, vbDirectory) = "" Then MkDir yearFolder

    ' デフォルトの保存パス
    savePath = yearFolder & "\【MVNO】Call_Center_Report_" & formattedDate & ".xlsx"
    fileExists = (Dir(savePath) <> "")

    ' ファイルがすでに存在するか確認
    If fileExists Then
        response = MsgBox("同じ名前のファイルが既に存在します。" & vbCrLf & _
                          "上書きしますか？" & vbCrLf & vbCrLf & _
                          "[はい]：上書き保存" & vbCrLf & _
                          "[いいえ]：保存先を指定" & vbCrLf & _
                          "[キャンセル]：処理を中止", _
                          vbYesNoCancel + vbExclamation, "ファイルの重複確認")

        Select Case response
            Case vbYes
                ' そのまま savePath を使用
            Case vbNo
                ' 名前を付けて保存ダイアログを表示
                altSavePath = Application.GetSaveAsFilename( _
                    InitialFileName:="【MVNO】Call_Center_Report_" & formattedDate & ".xlsx", _
                    FileFilter:="Excelファイル (*.xlsx), *.xlsx", _
                    Title:="保存先とファイル名を指定してください")
                
                If altSavePath = False Then
                    MsgBox "保存処理をキャンセルしました。", vbInformation
                    Exit Sub
                Else
                    savePath = altSavePath
                End If
            Case vbCancel
                MsgBox "保存処理をキャンセルしました。", vbInformation
                Exit Sub
        End Select
    End If

    ' シート名を定義
    sheetNames = Array("Hourly", "Monthly", "Daily")

    ' 最初のシートをコピーして新しいブック作成
    currentWb.Sheets(sheetNames(0)).Copy
    Set newWb = ActiveWorkbook

    ' 2枚目以降のシートを追加コピー
    For i = 1 To UBound(sheetNames)
        currentWb.Sheets(sheetNames(i)).Copy After:=newWb.Sheets(newWb.Sheets.count)
    Next i

    ' 保存
    Application.DisplayAlerts = False
    newWb.SaveAs fileName:=savePath, FileFormat:=xlOpenXMLWorkbook
    newWb.Close SaveChanges:=False
    Application.DisplayAlerts = True

    MsgBox "ファイルを保存しました：" & vbCrLf & savePath, vbInformation
    Exit Sub

DateError:
    MsgBox "「CSV取り込み」シートのセルA2に有効な日付がありません。", vbExclamation
End Sub