エクセルのマクロについて教えてください。

下記のマクロを実行すると
不要シートを削除し
ダイナログが開き、保存先フォルダを指定して
指定セル値名でブックが保存されます。
マクロの機能を残しつつ
保存先だけを下記の内容に変更できる方法を教えてください。
保存先を、このマクロを設定しているカレントフォルダの一つ上のフォルダに保存出来るようにしたいのですが、可能でしょうか。（メッセージ等が非表示）
よろしくお願いします。
現状のマクロ
Sub 審査保存1()
On Error Resume Next
Application.DisplayAlerts = False
Sheets(Array("F出張費", "F審査(紙)")).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Const folder As String = "\\nas-sp01\share\確認部\電子申請 関連\"
Dim newName As Variant
Dim initName As String
initName = folder & Range("U1").Value
newName = Application.GetSaveAsFilename(InitialFileName:=initName, FileFilter:="Excel マクロ有効ブック(*.xlsm), *.xlsm")
If newName = False Then Exit Sub
Dim WS As Worksheet
Dim TargetCheck As String
Dim List As Variant
Dim i As Long
Dim Chk As Boolean
List = Array("休日")
For Each WS In Worksheets
Chk = False
If WS.Visible = False Then
For i = 0 To UBound(List)
If WS.Name = List(i) Then
Chk = True
Exit For
End If
Next i
If Chk = False Then
TargetCheck = TargetCheck & WS.Name & vbCrLf
Application.DisplayAlerts = False
WS.Delete
Application.DisplayAlerts = True
End If
End If
Next WS
ThisWorkbook.SaveAs newName, xlOpenXMLWorkbookMacroEnabled
Application.ScreenUpdating = True
Application.Quit
With ThisWorkbook
.Saved = True
.Close False
End With
End Sub

以上です。

よろしくお願いします。

質問者からの補足コメント

• 

  回答ありがとうございます。
  教えて頂いたコードをどこに追加すればよいかがわかりません。
  ご指導よろしくお願いします。

  No.1の回答に寄せられた補足コメントです。 補足日時：2023/11/08 11:03

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2023/11/08 14:12

＃２

元コードが　.Saved = Trueなので
ThisWorkbook.Save　は　不要ですね・・消してください

No.2 回答者： Qchan1962 回答日時： 2023/11/08 14:08

＞このマクロを設定しているカレントフォルダ

は　ThisWorkbook.Pathで良いですか？
＞ "\\nas-sp01\share\確認部\電子申請 関連\"
の保存先には保存しなくてよいですか

Sub 審査保存1()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ThisWorkbook.Save
Sheets(Array("F出張費", "F審査(紙)")).Delete
Dim newName As String
newName = Worksheets("???").Range("U1").Value
Dim WS As Worksheet
Dim TargetCheck As String
Dim List As Variant
Dim i As Long
Dim Chk As Boolean
List = Array("休日")
For Each WS In Worksheets
Chk = False
If WS.Visible = False Then
For i = 0 To UBound(List)
If WS.Name = List(i) Then
Chk = True
Exit For
End If
Next i
If Chk = False Then
TargetCheck = TargetCheck & WS.Name & vbCrLf
WS.Delete
End If
End If
Next WS
With ThisWorkbook
newName = Left(.Path, InStrRev(.Path, "\") - 1) & "\" & newName
.SaveAs newName, xlOpenXMLWorkbookMacroEnabled
Application.Quit
.Close False
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Worksheets("???")　シートを明示してください

この回答へのお礼

回答ありがとうございます。
上手くできました。
感謝いたします。

お礼日時：2023/11/08 15:48

No.1 回答者： stomachman 回答日時： 2023/11/08 10:48

Workbookの.Path属性がそのWorkbookのファイルへのパスの文字列を表しています。

だから
p =　ThisWorkbook.Path
parentPath = Left(p, InStrRev(p, "\") - 1)
でよろしいかと。