作成した帳票をフォルダに自動保存するVBA

Option Explicit

Sub 伝票保存()
    Dim Mypath, FolderPathD As String
    Dim Shell As Object
    Dim Newbook As Object
    Dim FP, FPN, FPM, FPMN As String
    Dim FPL, FPLN, FN, NbkN As String
    Dim a As Long
'保存フォルダを選択
        Mypath = ThisWorkbook.Path & "\作成伝票"
    
        Set Shell = CreateObject("Shell.Application") _
            .BrowseForFolder(0, "フォルダを選択してください", _
                        &H1, Mypath)
        If Shell Is Nothing Then
            FolderPathD = ""
            Exit Sub
        Else
            FolderPathD = Shell.Items.Item.Path
        End If
'フォルダ名の取得
        FP = FolderPathD
        FPN = Mid(FP, InStrRev(FP, "\") + 1)
        FPM = Left(FP, InStrRev(FP, "\") - 1)
        FPMN = Mid(FPM, InStrRev(FPM, "\") + 1)
        FPL = Left(FPM, InStrRev(FPM, "\") - 1)
        FPLN = Mid(FPL, InStrRev(FPL, "\") + 1)
'ファイルを保存
        ChDir FP
        Set Newbook = Workbooks.Add
        For a = 2 To 4
            ThisWorkbook.Activate
            Worksheets(a).Cells.Copy
            Newbook.Activate
            Worksheets("sheet" & a - 1).Select
            With ActiveSheet
                .Paste
                .Name = ThisWorkbook.Worksheets(a).Name
'行高さ設定
                .Rows.RowHeight = 24
                .Rows("1:12").RowHeight = 19.5
                .Rows(1).RowHeight = 29.25
                .Rows(2).RowHeight = 9
                .Rows(4).RowHeight = 7.5
                .Rows("7:10").RowHeight = 15.75
                .Rows(11).RowHeight = 15.75
                .Rows(12).RowHeight = 7.5
                .Rows("13:14").RowHeight = 15.75
'列幅の設定
                .Columns("A").ColumnWidth = 3.5
                .Columns("B").ColumnWidth = 7.25
                .Columns("C").ColumnWidth = 27.63
                .Columns("D").ColumnWidth = 9.13
                .Columns("E").ColumnWidth = 6.63
                .Columns("F").ColumnWidth = 6
                .Columns("G").ColumnWidth = 4.75
                .Columns("H").ColumnWidth = 13.5
                .Columns("I").ColumnWidth = 7.5
'印刷余白の設定
                With .PageSetup
                    .TopMargin = Application _
                                        .CentimetersToPoints(1.5)
                    .LeftMargin = Application _
                                        .CentimetersToPoints(2)
                    .RightMargin = Application _
                                        .CentimetersToPoints(1)
                    .BottomMargin = Application _
                                        .CentimetersToPoints(1)
                    .HeaderMargin = Application _
                                        .CentimetersToPoints(0.5)
                    .FooterMargin = Application _
                                        .CentimetersToPoints(0.5)
'プリントタイトル
                    .PrintTitleRows = "$15:$15"
'ページ番号
                    .CenterFooter = "&P"
                End With
            End With
            Application.CutCopyMode = False
        Next a
'保存ファイルに名前を付ける
        FN = Format(Now(), "yymmdd-hhmm")
        With Newbook
            If FPN = "作成伝票" Then
                .SaveAs Filename:=FolderPathD & "\" _
                            & FPN & "請求書_" & FN & ".xlsx"
            ElseIf FPMN = "作成伝票" Then
                .SaveAs Filename:=FolderPathD & "\" _
                            & FPN & "請求書_" & FN & ".xlsx"
            ElseIf FPLN = "作成伝票" Then
                .SaveAs Filename:=FolderPathD & "\" _
                        & FPMN & FPN & "請求書_" & FN & ".xlsx"
            Else
                .SaveAs Filename:=FolderPathD & "\" _
                & FPLN & FPMN & FPN & "請求書_" & FN & ".xlsx"
            End If
            NbkN = .Name
            .Close
        End With
        ThisWorkbook.Activate
        Worksheets("作業シート").Activate
        Range("A1").Select
        MsgBox NbkN & "　で帳票の保存を行ないました。", _
                    vbInformation, "インボイス見積納品請求3点日付版作成"
End Sub