モジュールです。

Sub SP_8670ShtDup(strHinaPATH As String, strSitePATH As String, intSiteCol As Integer, intTLsu As Integer, strOutPath As String, strOutName As String)

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

'@ シートの複製

'* 注意事項；これはサンプルであり、様々な機能や例外処理等は省略しています

'*           実際にお使いになる場合は例外処理や各種機能の追加変更を行って下さい

'* [INPUT]  strHinaPATH AS string           '==ひな形ブックのフルパス   例) d:\test\ひな形.xlsx    複数シート可能

'*          strSitePATH AS string           '==作成指定ブックのフルパス 例) d:\test\指定.xlsx      第１シートが対象

'*          intSiteCol  AS INTEGER          '==作成指定ブックのデータのある列  例) 2

'*          intTLsu     AS INTEGER          '==作成指定ブックのタイトル数（この行数分は対象としない)

'*          strOutPath AS STRING            '==保存パスと名前                    例)  D:\TEST\

'*          strOutName AS STRING            '==保存パスに付ける名前 VVVの部分    例)  D:\TEST\   AA.XLS  --> D:\TEST\VVV_XXX.xlsx

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

Dim obj作成ブック As Object

Dim objひな形ブック As Object

Dim intSetLoop As Integer

Dim intHLoop As Integer

Dim lngTmp As Long

Dim strSShtName() As String

Dim strNowSetSht As String

Dim strSakuPath As String

Dim bolRet As Boolean

'

'***作成指定ブックの作成指定ブックのデータのある列のデータを得る

    Call SP_8670ShtDup_GetSSht(strSitePATH, intSiteCol, intTLsu, strSShtName())

'

'***ひな形ブックOPEN

    Set objひな形ブック = Workbooks.Open(FileName:=strHinaPATH)

'

'***作成するブックに作成されるシート数を１にする

    lngTmp = Application.SheetsInNewWorkbook

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

  

'***作成指定ブックのデータでLoop

    For intSetLoop = 1 To UBound(strSShtName)

        Set obj作成ブック = Workbooks.Add

        For intHLoop = 1 To objひな形ブック.Worksheets.Count

            objひな形ブック.Worksheets(intHLoop).Copy BEFORE:=obj作成ブック.sheets(1)

'..............................................................................................................下記３行はちょっとだけ実用的にする為にシート名/ひな形にある#A#を置き換える時 不要なら削除

            strNowSetSht = objひな形ブック.Worksheets(intHLoop).Name & "_" & strSShtName(intSetLoop)

            obj作成ブック.Worksheets(1).Name = strNowSetSht                                                                                                           '==シート名を変更

            bolRet = obj作成ブック.Worksheets(1).Cells.Replace(WHAT:="#A#", Replacement:=strSShtName(intSetLoop), LOOKAT:=False, MatchCase:=False, MatchByte:=False)  '==#A#をデータで置き換え

'..............................................................................................................

        Next

        obj作成ブック.Worksheets("Sheet1").Delete   '==不要なシートは削除

        strSakuPath = strOutPath & strOutName & strSShtName(intSetLoop) & ".XLSX"

        Application.StatusBar = strSakuPath           '==ステータスバーに表示

        Application.DisplayAlerts = False             '==上書き時の警告をださない(警告を出したければこの行は削除)

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

        Application.DisplayAlerts = True

        obj作成ブック.CLOSE (False)

        Set obj作成ブック = Nothing

    Next

'

'***後始末

    objひな形ブック.CLOSE (False)

    Set objひな形ブック = Nothing

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

  

'***EXIT

    Exit Sub

End Sub

Sub SP_8670ShtDup_GetSSht(strSitePATH As String, intSiteCol As Integer, intTLsu As Integer, strSShtName() As String)

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

'@ 作成指定ブックの作成指定ブックのデータのある列のデータを得る

'* [INPUT]  strSitePATH AS string           '==作成指定ブックのフルパス 例) d:\test\指定.xlsx      第１シートが対象

'*          intSiteCol  AS INTEGER          '==作成指定ブックのデータのある列  例) 2

'*          intTLsu     AS INTEGER          '==作成指定ブックのタイトル数（この行数分は対象としない)

'* [OUTPUT] strSShtName() AS STRING         '==作成指定ブックの作成指定ブックのデータのある列のデータ

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

Dim obj指定ブック As Object

Dim obj指定シート As Object

Dim lngMaxRow As Long

Dim intIdx As Integer

Dim lngRow As Long

'

'***作成指定ブックOPENして対応セルのデータを得る

    Set obj指定ブック = Workbooks.Open(FileName:=strSitePATH)

    Set obj指定シート = obj指定ブック.sheets(1)

'

'***最大行をえる

    lngMaxRow = obj指定シート.Cells(obj指定シート.Rows.Count, intSiteCol).End(xlUp).Row     '==最大行数を得る

    ReDim strSShtName(lngMaxRow - intTLsu)

'

'***データ取得

    intIdx = 0

    For lngRow = intTLsu + 1 To lngMaxRow

        intIdx = intIdx + 1

        strSShtName(intIdx) = TRIM$(obj指定シート.Cells(lngRow, intSiteCol).VALUE)

    Next

'

'***作成指定ブックは以降不要

    obj指定ブック.CLOSE

    Set obj指定シート = Nothing

    Set obj指定ブック = Nothing

'

'***EXIT

    Exit Sub

End Sub

  

  

テスト用メインです

Sub TestMain()

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

'@ 8660_エクセルブックのシートをブックに分割のテスト用メイン

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

Dim strHinaPATH As String       '==ひな形ブックのフルパス   例) d:\test\ひな形.xlsx    複数シート可能

Dim strSitePATH As String       '==作成指定ブックのフルパス 例) d:\test\指定.xlsx      第１シートが対象

Dim intSiteCol  As Integer      '==作成指定ブックのデータのある列  例) 2

Dim intTLsu As Integer          '==作成指定ブックのタイトル数（この行数分は対象としない)

Dim strOutPath As String        '==保存パスと名前 この後にシート名がつく 例)  D:\TEST\月次   AA.XLS  --> D:\TEST\月次_XXX.xlsx

Dim strOutName As String        '==保存パスに付ける名前 VVVの部分    例)  D:\TEST\   AA.XLS  --> D:\TEST\VVV_XXX.xlsx

'

'***TEST用データブック

    strHinaPATH = ThisWorkbook.sheets(1).Range("DataPath")

    If strHinaPATH = "" Then

       MSGBOX "TEST用ひな形ブックを指定して下さい"

       Exit Sub

    End If

'

'***TEST用出力フォルダ

    strSitePATH = ThisWorkbook.sheets(1).Range("DataPath2")

    If strSitePATH = "" Then

       MSGBOX "TEST用作成指定ブックを指定して下さい"

       Exit Sub

    End If

'

'***TEST用出力フォルダ

    strOutPath = ThisWorkbook.sheets(1).Range("DataPath3")

    If strOutPath = "" Then

       MSGBOX "TEST用に書き出すフォルダを指定して下さい"

       Exit Sub

    End If

    If Right$(strOutPath, 1) <> "\" Then strOutPath = strOutPath & "\"

'

'***CALL

    intSiteCol = 3

    intTLsu = 1

    strOutName = "月次_"

    Call SP_8670ShtDup(strHinaPATH, strSitePATH, intSiteCol, intTLsu, strOutPath, strOutName)

'

'***EXIT

    MSGBOX "処理は終了しました"

End Sub