workbook シートのマージ

Option Explicit
Private isAllSheetsFlag As Boolean
Private isSheetNameMergeBookNameFlag As Boolean
Private mWorkBook As Workbook
Function StartMergeSheetsOneBook()
  Call mergeSheetsOneBookMain(False)
End Function
Function mergeSheetsOneBookMain(Optional isAllSheets As Boolean = True, Optional isSheetNameMergeBookName = True)
'■指定したブックにシートを集める
'集めるブックはオープンにしておく
  '全てのシート
  isAllSheetsFlag = isAllSheets
  'シート名をブック名とマージする
  isSheetNameMergeBookNameFlag = isSheetNameMergeBookName
  Call decideMergeBookType
  Call selectAction(Application.Workbooks)
End Function
Function decideMergeBookType() As Workbook
'ブックを新規作成するか既存のブックを選択するか選ぶ
  Dim isNewBook As VbMsgBoxResult, dirStr As String
  isNewBook = MsgBox("収集先ブックを新規作成しますか？", vbYesNo)
  Select Case isNewBook
    Case vbYes
      Set mWorkBook = Workbooks.Add
      Debug.Print "Yes：ブック新規作成" & Time  '★
      Debug.Print "転記先ブック："; mWorkBook.Name  '★
    Case vbNo
      Debug.Print "No:既存ブック選択" & Time  '★
      dirStr = Application.GetOpenFilename("MicrosoftExcelブック,*.xls?")
      Workbooks.Open dirStr
      Set mWorkBook = Workbooks(Dir(dirStr))
      Set decideMergeBookType = Workbooks(Dir(dirStr))
  End Select
End Function
Function selectAction(wsList As Workbooks)
'実処理
  Dim buf, bookName As String
  For Each buf In wsList
    bookName = buf.Name
    Select Case True
      Case bookName = mWorkBook.Name
        Debug.Print bookName & "は転記先ブックにて非処理"  '★
      Case bookName = ThisWorkbook.Name
        Debug.Print bookName & "はマクロブックにて非処理"  '★
      Case bookName <> mWorkBook.Name
        Call margeSheets(Workbooks(bookName))
    End Select
  Next
End Function
Function margeSheets(wb As Workbook)
  Dim buf, shList As Sheets, bookName As String
  bookName = wb.Name
  Select Case isAllSheetsFlag
    Case True
      Debug.Print bookName & "の全てのシートに対して処理を行う"  '★
      Set shList = wb.Worksheets
    Case False
      Debug.Print bookName & "の選択されたシートに対して処理を行う"  '★
      Set shList = wb.Windows(1).SelectedSheets
  End Select
  For Each buf In shList
    Debug.Print buf.Name & "をコピーして閉じる" '★
    'mWorkBookの最後尾にシートをコピーする
    Call copySheetToEnd(mWorkBook, Workbooks(bookName).Worksheets(buf.Name))
    'ブック名とシート名をマージする
    If isSheetNameMergeBookNameFlag Then
      mWorkBook.Worksheets(Sheets.Count).Name = mergeBookNameToSheetNames(buf.Name, bookName)
    End If
  Next
  'ワークブックを閉じる
  Workbooks(bookName).Close
End Function
Function copySheetToEnd(mergeWorkBook As Workbook, targetSheet As Worksheet)
'mergeWorkbookの最後尾にtargetWorkBookのシートをマージする
  targetSheet.Copy _
      After:=mergeWorkBook.Sheets(mergeWorkBook.Sheets.Count)
End Function
Function mergeBookNameToSheetNames(sheetName As String, bookName As String) As String
'■シート名とブック名をマージする
  Dim sNameNum As Long, bNameNum As Long, overNum As Long, adjustBNameNum As Long
  sNameNum = Len(sheetName)
  bNameNum = Len(bookName)
  Select Case True
    Case sNameNum + bNameNum + Len("_") <= 30
      mergeBookNameToSheetNames = sheetName & "_" & bookName
    Case Else
      overNum = (sNameNum + bNameNum + Len("_")) - 30
      adjustBNameNum = bNameNum - overNum
      mergeBookNameToSheetNames = sheetName & "_" & Mid(bookName, 1, adjustBNameNum)
  End Select
End Function