モジュールです。

Sub Sp8660_BookSht(strBookPATH As String, strOutPath As String)

'****************************************************************

'@ エクセルのシートをブックに分割

'* [INPUT]   strBookPATH AS STRING             '==対象のブックのパス 例)D:\TET\AA.XLSX

'*           strOutPath AS STRING              '==保存パス この後にブック名シート名がつく 例) D:\TEST\   AA.XLS  --> D:\TEST\AA_SNAM.XLS

'***************************************************************

Dim obj読込ブック As Object

Dim intShtLoop As Integer

Dim strTaiSht As String

Dim strRtcd As String

Dim intShtName_Su As Integer              '==シート数

Dim strShtName(1 To 512) As String        '==シート名

'

'***対象ブックOPEN

    Set obj読込ブック = Workbooks.Open(FileName:=strBookPATH)

  

'***シート名の取得()

    intShtName_Su = 0

    For intShtLoop = 1 To obj読込ブック.Worksheets.Count

        intShtName_Su = intShtName_Su + 1

        strShtName(intShtName_Su) = obj読込ブック.Worksheets(intShtLoop).NAME

    Next

'

'***シートでLOOP

    For intShtLoop = 1 To intShtName_Su

        strTaiSht = strShtName(intShtLoop)

        Call Sp8660_BookSht_SHT(obj読込ブック, strTaiSht, strOutPath, strRtcd)      '==エクセルのシートをブックに分割 (１シート毎)

        If strRtcd <> "OK" Then

           MSGBOX strRtcd

           Exit For

        End If

    Next

    Set obj読込ブック = Nothing

'

'***終了

    Exit Sub

End Sub

Sub Sp8660_BookSht_SHT(obj読込ブック As Object, strTaiSht As String, strOutPath As String, strRtcd As String)

'****************************************************************

'@ エクセルのシートをブックに分割 (１シート毎)

'* [INPUT]   obj読込ブック AS OBJECT           '==対象のブック

'*           strTaiSht AS STRING               '==対象のブックの対象シート

'*           strOutPath AS STRING              '==保存パス この後にブック名シート名がつく 例) D:\TEST\   AA.XLS  --> D:\TEST\AA_SNAM.XLS

'* [OUTPUT]  strRtcd AS STRING                 '=="OK" 以外はエラー内容

'***************************************************************

Dim obj作成ブック As Object

Dim lngTmp As Long

Dim strSakuFullPath As String

'

'***新たなブックを作成

    lngTmp = Application.SheetsInNewWorkbook

    Application.SheetsInNewWorkbook = 1               '==新規ブック追加時のシート枚数を変更

    Set obj作成ブック = Workbooks.Add

    Application.SheetsInNewWorkbook = lngTmp          '==設定を元に戻す

'

'***保存ファイル名を決定

    strSakuFullPath = strOutPath                                             '==D:\TEST\

    strSakuFullPath = strSakuFullPath & obj読込ブック.NAME                   '==D:\TEST\ABC

    strSakuFullPath = strSakuFullPath & "_" & strTaiSht                      '==D:\TEST\ABC_SHT

    strSakuFullPath = strSakuFullPath & ".xlsx"                              '==D:\TEST\ABC_SHT.xlsx

  

'***シートを複写

    On Error GoTo ERR1

    obj読込ブック.Worksheets(strTaiSht).Copy after:=obj作成ブック.Worksheets(1)

    On Error GoTo 0

'

'***不要なシートを削除

    obj作成ブック.Worksheets(1).Delete

'

'***保存

    obj作成ブック.SaveAs FileName:=strSakuFullPath

    obj作成ブック.Close (False)

'

'***後始末

    Set obj作成ブック = Nothing

'

'***終了

    strRtcd = "OK"

    Exit Sub

'===========================================================================

'=  エラーハンドリング(03.製造工程スケジュール.xlsで発覚

'===========================================================================

ERR1:

    strRtcd = "シート複写エラー " & strTaiSht

    Exit Sub

End Sub

'

テスト用メインです