再編集

Sub SaveSelectedSheetsToNewWorkbook()
    Dim wsDate As Worksheet
    Dim targetDate As Date
    Dim formattedDate As String
    Dim yearFolder As String
    Dim monthFolder 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

    ' 初期設定
    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

    monthFolder = yearFolder & "\" & Format(targetDate, "mm")
    If Dir(monthFolder, vbDirectory) = "" Then MkDir monthFolder

    ' 保存ファイルパスの設定
    savePath = monthFolder & "\【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
```

---

### ✅ 保存先フォルダ構成例（2025年6月1日をA2に入力した場合）

```
C:\Users\matsu\Desktop\提出用\
└─2025\
   └─06\
      └─【MVNO】Call_Center_Report_20250601.xlsx
```