シート切り出し

機能

• 対象ブックに指定したシート名のシートを追加する。
• 新規ブックにシートを追加する場合、指定したファイル名で保存する。
• 既存のブックにシートを追加する場合、上書き保存する。
• シート追加時に「目次」へ戻るための関数を埋め込むイベント処理が発動する都合で、対象ファイルに「目次」シートが存在しない場合は「目次」を追加する。

シート建付け

• シート名
  シート切り出し
• シート構成
  • 保存先のフォルダパス　→　C3
  • 新規ブック名 or 既存ブック名　→　C5
  • Noの表示はシート上の関数で行っている。
    • 例）= IF(B10<>"", ROW()-9, "")
  • 追加するシート名（B列）が重複しているかは、シート上の条件付き書式で検査する。
    

ソースコード

Module1

• 共通設定

'シート名
Public Const SHEET_NAME_INDEX = "目次"
Public Const SHEET_NAME_INDEX_TMP = "目次tmp" '非表示
Public Const SHEET_NAME_EXPORT_SHEET = "シート切り出し"
'シート命名ルール
Public Const SHEET_NAME_NG_LIST = "',’,＇,*,:,?,\,￥,＊,／,：,？,[,［,］,],＼,/,<,>"
Public Const MAX_SHEET_NAME_NUM = 31
'拡張子
Public Const EXCEL_EXTENSION = ".xlsx"
'オブジェクト
Public Const DICTIONARY = "Scripting.Dictionary"
'区切り文字
Public Const DELIMITER_BS = "\"
Public Const DELIMITER_C = ","

• 処理

'***** シート切り出し *****
Sub ExportSheets()

    '行数
    Const TARGET_FOLDER_PATH_ROW = 3
    Const TARGET_FILE_NAME_ROW = 5
    Const START_SHEET_NAME_ROW = 10
    '列数
    Const TARGET_FOLDER_PATH_COL = 3
    Const TARGET_FILE_NAME_COL = 3
    Const NO_COL = 1
    Const SHEET_NAME_COL = 2
    Const RESULT_COL = 3
    '関数
    Const RETURN_INDEX_FORMULA = _
        "= IFERROR(HYPERLINK(""#'目次'!B"" & MATCH(RIGHT(CELL(""filename"", A1), LEN(CELL(""filename"", A1)) - FIND(""]"", CELL(""filename"", A1))), 目次!B:B, 0), ""戻る""), """")"
    '文言
    Const END_MESSAGE = "切り出し完了"
    Const EMPTY_MESSAGE = "シート名を記入してください"

    '編集行 初期化
    Dim workRow As Long
    workRow = START_SHEET_NAME_ROW
    'シート名連番 初期化
    Dim sheetNum As Long
    sheetNum = 0
    
    
    '処理前アクション
    StartAction SHEET_NAME_EXPORT_SHEET, False
    
    
    '最大行
    Dim maxRow As Long
    maxRow = GetMaxRow(SHEET_NAME_EXPORT_SHEET, SHEET_NAME_COL)
    '保存先のフォルダパス
    Dim targetFolderPath As String
    targetFolderPath = Cells(TARGET_FOLDER_PATH_ROW, TARGET_FOLDER_PATH_COL).Value
    '対象ファイル名
    Dim targetFileName As String
    targetFileName = Cells(TARGET_FILE_NAME_ROW, TARGET_FILE_NAME_COL).Value & EXCEL_EXTENSION
    
    
    'シート名カウント
    Dim sheetNameCount As Long
    
    If maxRow >= START_SHEET_NAME_ROW Then
        sheetNameCount = WSF_COUNTA(START_SHEET_NAME_ROW, maxRow, SHEET_NAME_COL) - 1
    Else
        sheetNameCount = 0
    End If
    
    Dim sheetNames() As String
    Dim arrayCnt As Long
    ReDim sheetNames(sheetNameCount)
    arrayCnt = UBound(sheetNames)
    
    
    'シート名 格納
    Dim i As Long
    
    If arrayCnt > 0 Then
        For i = 0 To arrayCnt
            sheetNames(i) = _
                FormatSheetName(WSF_TEXT(sheetNum, "00") & "_" & Cells(workRow, SHEET_NAME_COL).Value)
            '同名回避
            If SheetExistCheck(ThisWorkbook.Name, sheetNames(i)) = True Then
                sheetNames(i) = Left(sheetNames(i), MAX_SHEET_NAME_NUM - 3) & "(2)"
            End If
            '編集行 更新
            workRow = workRow + 1
            'シート連番 更新
            sheetNum = sheetNum + 1
        Next i
    Else
        MsgBox EMPTY_MESSAGE
        Exit Sub
    End If
    

    '切り出し先ブック 準備
    Dim checkFullPath As String
    Dim exportBookName As String
    
    checkFullPath = targetFolderPath & DELIMITER_BS & targetFileName
    
    If Dir(checkFullPath) = "" Then
        Workbooks.Add
        exportBookName = ActiveWorkbook.Name
    Else
        Workbooks.Open checkFullPath
        exportBookName = SplitFileName(checkFullPath)
    End If

    ThisWorkbook.Activate
    
    
    'シート追加
    Dim sheetName As Variant

    For Each sheetName In sheetNames
        Worksheets.Add after:=Worksheets(Worksheets.Count) 'シート追加
        ActiveSheet.Name = sheetName 'シート名 変更
    Next
    
    
    '「目次」シート追加
    '不要な場合はコメントアウト ===============================
    If SheetExistCheck(exportBookName, SHEET_NAME_INDEX) <> True Then
        With ThisWorkbook.Sheets(SHEET_NAME_INDEX_TMP)
            .Visible = True
            .Copy before:=Workbooks(exportBookName).Sheets(1)
            .Visible = False
            Workbooks(exportBookName).Sheets(SHEET_NAME_INDEX_TMP).Name _
                = SHEET_NAME_INDEX
         End With
         ThisWorkbook.Activate
    End If
    '================================================
    
    
    'アラート停止
    Application.DisplayAlerts = False
    
    
    'シート移動
    Dim sName As Variant
    
    For Each sName In sheetNames
        
        If SheetExistCheck(exportBookName, sName) <> True Then
            
            With Workbooks(exportBookName)
                ThisWorkbook.Sheets(sName).Copy after:=.Sheets(.Worksheets.Count)
                '不要な場合はコメントアウト ===============================
                '「戻る」更新
                .Sheets(sName).Range("A1").Value = RETURN_INDEX_FORMULA
                '================================================
            End With
            
            'コピー元シート 削除
            ThisWorkbook.Activate
            Sheets(sName).Delete
        End If
    
    Next

    
    '（新規ブックの場合）オープン時に作成されるシート 削除
    If Dir(targetFolderPath & DELIMITER_BS & exportBookName) = "" Then
        DeleteDefaultSheet exportBookName
    End If
    
    Workbooks(exportBookName).Sheets(1).Activate
    

    'アラート再開
    Application.DisplayAlerts = True
    
    
    '保存
    SaveCase targetFolderPath, exportBookName, targetFileName
    

    '処理後アクション
    EndAction SHEET_NAME_EXPORT_SHEET, END_MESSAGE

End Sub

Module2

'■ ■ ■　よく使う処理　■ ■ ■

'***** 処理前アクション *****
'機能：処理開始前にExcelの描画を止める（任意）
Sub StartAction(ByVal sheetName As String, Optional ByVal ScreenUpdateFlag As Boolean = True)

    ThisWorkbook.Activate
    
    '描画停止
    If ScreenUpdateFlag = False Then
        Application.ScreenUpdating = ScreenUpdateFlag
    End If
    
    '対象シート 有効化
    Worksheets(sheetName).Activate

End Sub


'***** 処理後アクション *****
'機能：① Excelの描画を再開させる。
'　　：② [Ctrl + HOME] を押下した位置にカーソルを移動させる。
'　　：③ 終了メッセージを表示させる。
Sub EndAction(ByVal sheetName As String, ByVal endMessage As String)

    ThisWorkbook.Activate
    
    '描画再開
    Application.ScreenUpdating = True
    
    '対象シート 有効化
    Sheets(sheetName).Activate
    
    'Ctrl + HOMEの位置にカーソル移動
    With ActiveWindow
        ActiveWindow.ActiveSheet.Cells(.SplitRow + 1, .SplitColumn + 1).Activate
    End With
    
    '終了メッセージ 表示
    MsgBox endMessage

End Sub


'***** デフォルトシート 削除 *****
'機能：ブックを開いたときに作成されるシートを削除する。
Sub DeleteDefaultSheet(ByVal bookName As String, Optional ByVal alertFlag As Boolean = True)

    '削除するシート名
    Const DELETE_SHEET_NAME_1 = "Sheet1"
    
    'アラート OFF
    If alertFlag = False Then
        Application.DisplayAlerts = False
    End If
    
    'シート削除
    With Workbooks(bookName)
        .Sheets(DELETE_SHEET_NAME_1).Delete '※削除したいシート分、実行する。
    End With
    
    'アラート再開
    If alertFlag = False Then
        Application.DisplayAlerts = True
    End If

End Sub


'***** 最大行 取得 *****
'機能：最大行を取得する。
Function GetMaxRow(ByVal targetSheetName As String, ByVal targetCol As Long) As Long

    GetMaxRow = Sheets(targetSheetName).Cells(Rows.Count, targetCol).End(xlUp).Row

End Function


'***** シート数 取得 *****
'機能：対象ブックのシート数を取得する。
Function GetSheetCount(ByVal targetBookName As String) As Long

    GetSheetCount = Workbooks(targetBookName).Sheets.Count

End Function


'***** 対象範囲 クリア *****
'機能：対象範囲の値のみを削除する。
Sub ClearContents(ByVal sheetName As String, ByVal startRow As Long, ByVal endRow As Long, ByVal startCol As Long, ByVal endCol As Long)

    Sheets(sheetName).Range( _
        Cells(startRow, startCol), Cells(endRow, endCol) _
    ).ClearContents

End Sub


'***** ファイル名 抽出 *****
'機能：フルパスからファイル名を抽出する。
Function SplitFileName(ByVal targetFullPath As String, Optional ByVal splitDelimiter As String = "\") As String

    Dim delimiterPos As Long
    delimiterPos = InStrRev(targetFullPath, splitDelimiter)
    
    SplitFileName = Mid(targetFullPath, delimiterPos + 1)

End Function


'***** シート存在チェック *****
'機能：特定の名前のシートが存在するかチェックする。
Function SheetExistCheck(ByVal targetBookName As String, ByVal targetSheetName As String) As Boolean
    
    Dim ws As Worksheet
    Dim checkResult As Boolean

    Workbooks(targetBookName).Activate
        
    '存在チェック
    For Each ws In Worksheets
        If ws.Name = targetSheetName Then
            checkResult = True
            Exit For
        Else
            checkResult = False
        End If
    Next
    
    SheetExistCheck = checkResult
    
End Function


'***** COUNTA関数 使用 *****
'機能：COUNTA関数の結果を返す。
Function WSF_COUNTA(ByVal startRow As Long, ByVal endRow As Long, ByVal startCol As Long, Optional ByVal endCol As Long = 0) As Long
    
    Dim workCol As Long
    
    If endCol = 0 Then
        workCol = startCol
    Else
        workCol = endCol
    End If
    
    WSF_COUNTA = _
        Application.WorksheetFunction.CountA( _
            Range(Cells(startRow, startCol), Cells(endRow, workCol)) _
        )

End Function


'***** シート名 整形 *****
'機能：対象文字列からシート名禁則文字を除外する（対象が32文字以上の場合、左から31文字を抜き出す）
Function FormatSheetName(ByVal targetSheetNaem As String) As String
    
    Dim sheetNameNGList As Variant
    Dim ngStr As Variant
    Dim tmpName As String
    tmpName = targetSheetNaem
    
    sheetNameNGList = Split(SHEET_NAME_NG_LIST, DELIMITER_C)
    
    For Each ngStr In sheetNameNGList
        tmpName = Replace(tmpName, ngStr, "")
    Next
    
    FormatSheetName = Left(tmpName, MAX_SHEET_NAME_NUM)

End Function


'***** TEXT関数 使用 *****
'機能：TEXT関数の結果を返す。
Function WSF_TEXT(ByVal targetNum As Long, ByVal textFormat As String) As String
    
    
    WSF_TEXT = Application.WorksheetFunction.Text(targetNum, textFormat)
    
End Function


'***** 場合分け保存 *****
'機能：対象ファイルが存在する場合は上書き保存、新規の場合は名前をつけて保存する。
Sub SaveCase(ByVal targetFolderPath As String, ByVal targetFileName As String, Optional ByVal tmpName As String = "")
    
    Dim saveName As String
    
    If tmpName = "" Then
        saveName = targetFileName
    Else
        saveName = tmpName
    End If
        
    Dim targetPath As String
    targetPath = targetFolderPath & DELIMITER_BS & saveName
    
    Workbooks(targetFileName).Activate
    
    If Dir(targetPath) = "" Then
        ActiveWorkbook.SaveAs targetPath
    Else
        ActiveWorkbook.Save
    End If
    
End Sub

ソースコードの全量は こちら
※転記漏れがあるかもしれないので。