VBAでExcelで複数選択中のシートを1枚ずつ新規ブックに切り出して保存

やりたいこと

VBAで、Excelで複数選択しているシートを1枚ずつ新規ブックに切り出して保存したい。

シートを複数選択中

保存先はとりあえずデスクトップで。

環境

• OS: Windows 11 Pro
• Excel: Microsoft Excel for Microsoft 365 MSO (バージョン 2307 ビルド 16.0.16626.20170) 64 ビット

やったこと／結果

VBAの新規標準モジュールに以下を書いて実行したところ、意図したように動いた。
切り出すと言っても、シートを「移動」させるのではなく「コピー」させるようにしたけど。

作ったコード

Option Explicit

Sub SaveEechSelectedSheetAsNewBook()

Dim folder As String
Dim PickedSheet As Object

'保存先のパスを取得する準備。環境変数%userprofile%の結果を取得。
folder = Environ("userprofile")

'選択したシート各自だけのブックをそれぞれ新規作成・保存・閉じ
For Each PickedSheet In ActiveWindow.SelectedSheets
PickedSheet.Copy
ActiveWorkbook.SaveAs folder & "\Desktop\" & PickedSheet.Name & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Next PickedSheet

End Sub