Sub MySheetSelect()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 複数ブック指定シート選択処理
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   コンボボックスでシート名を指定し、
  Rem   開いたブック（複数可）のシートを選択する。
  Rem 注記...
  Rem   1. MySheetSelectを実行して、コンボボックスをExcelウィンドウ上部に追加。
  Rem   2. 但し、シート名の左6文字が「Sheet#」（「#」は1文字の数字）の場合、
  Rem      コンボボックスに取り込まない。
  Rem   3. コンボボックスをからシート名を選択して使用。
  Rem 履歴...
  Rem   第01版：2007/01/25 作成。
  Rem   第02版：2007/07/19 コンボボックスに取り込むシートが0件の場合は処理中止。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myNewBook As Workbook
  Dim myWorkbook As Workbook
  Dim mySheet As Worksheet
  Dim myArray As Variant
  '
  Dim myWorkbookPrev As String
  Dim mySheetPrev As String
  '
  Dim i As Long
  Dim c As Range
  Dim myBook As Variant
  '
  Dim myCmmdBar As CommandBar
  Dim myCtrlCbox As CommandBarControl
  Dim myCtrlIcon As CommandBarControl
  Dim myListIndex As Long
  Dim myTitle As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MySheetSelect"
  myWorkbookPrev = ActiveWorkbook.Name
  mySheetPrev = ActiveSheet.Name
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.ScreenUpdating = False
  Set myNewBook = Workbooks.Add ' (xlWBATExcel4MacroSheet)
  i = 0
  For Each myWorkbook In Workbooks
    i = i + 1
    myNewBook.ActiveSheet.Cells(i, 1) = myWorkbook.Name
  Next ' myWorkbook
  '
  Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  ActiveSheet.UsedRange.Select
  '
  myBook = ""
  For Each c In Selection
    If c.Value <> myNewBook.Name Then
      myBook = myBook & c.Value & ";"
    End If
  Next ' c
  myNewBook.Close SaveChanges:=False
  Application.ScreenUpdating = True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  On Error Resume Next
  CommandBars(myTitle).Delete
  On Error GoTo 0
  '
  Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarTop, Temporary:=True)
  Set myCtrlCbox = myCmmdBar.Controls.Add(Type:=msoControlComboBox, Before:=1, Temporary:=True)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myBook = Left(myBook, Len(myBook) - 1)
  myArray = Split(myBook, ";")
  '
  With myCtrlCbox
    .DescriptionText = "コマンドバーを表示させ、コンボボックスから選択させます。"
    .Style = msoComboLabel
    .Caption = "シート：" ' "シート選択"
    .TooltipText = "表示したいシートを選んで下さい。"
    i = 0
    For Each myBook In myArray
      Workbooks(myBook).Activate
      For Each mySheet In ActiveWorkbook.Worksheets
        If Not Left(mySheet.Name, 6) Like "Sheet#" Then
          i = i + 1
          .AddItem mySheet.Name, i
          If mySheet.Name = mySheetPrev Then
            myListIndex = i
          End If
        End If
      Next ' mySheet
    Next ' myBook
    If i = 0 Then
      myCmmdBar.Delete
      Exit Sub
    End If
    .DropDownLines = i
    .DropDownWidth = 300
    .ListIndex = myListIndex ' 0
    .OnAction = "MySheetSelectOne"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Workbooks(myWorkbookPrev).Activate
  Sheets(mySheetPrev).Activate
  '
  myCmmdBar.Visible = True
  '
  Set myNewBook = Nothing
  Application.Speech.Speak "処理が終了しました。"
End Sub ' MySheetSelect *----*----*    *----*----*    *----*----*    *----*----*

Sub MySheetSelectOne(Optional MyDummy As Boolean)
  Dim myWorkbook As Workbook
  Dim mySheet As Worksheet
  '
  Dim MySheetSelect As String
  Dim myFlag As Boolean
  Dim myTitle As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MySheetSelect"
  MySheetSelect = CommandBars(myTitle).Controls(1).Text
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myFlag = False
  For Each myWorkbook In Workbooks
    On Error Resume Next
    myWorkbook.Activate
    Sheets(MySheetSelect).Activate
    '
    If Err.Number = 0 Then
      myFlag = True
      Exit For
    End If
    On Error GoTo 0
  Next ' myWorkbook
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Beep
  If myFlag = False Then
    MsgBox "指定したシートのブックが既に閉じています。"
  End If
End Sub ' MySheetSelectOne *----*----*    *----*----*    *----*----*    *----*----*