Excelファイルをシート毎に分割する

Excelファイル(ブック)をシート毎に分割して保存したいということが稀にある。

1. 分割したいExcelファイル(ブック)に以下のマクロを登録する。
2. マクロを実行する。
3. シート名がファイル名になったExcelファイル(ブック)ができあがる。

Sub 分割()
    Dim i As Integer
    Dim N As Integer 'ファイル作成数のカウンタ
    Dim Filename As String '保存するファイル名

    Application.ScreenUpdating = False '画面更新を停止

    i = 1
    Do While i <= Worksheets.Count
        Filename = Worksheets(i).Name
        Worksheets(i).Copy
        With ActiveWorkbook
            .SaveAs ThisWorkbook.Path & "\" & Filename & ".xls" '元ファイルと同フォルダに保存する
            .Close
            N = N + 1
        End With
        i = i + 1
    Loop
    
    Application.ScreenUpdating = True '画面更新を再開
    MsgBox N & " 個のブックを作成しました。"
End Sub

デスクトップで実行して、デスクトップがExcelアイコンで埋まった...。