シート一覧を作成するモジュールです。

Sub SP8600_ShtItiCre(obj対象ブック As Object)

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

'@  シート一覧を作成する（ハイパーリンク付き)

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

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

Dim strShtNam As String

Dim strRange As String

Dim strAddress As String

Dim strSubAddress As String

Dim strDisplay As String

Dim strShtNm As String

Dim intShAri As Integer

Dim lng設定行 As Long

Dim intLoop As Integer

Dim intShtName_Su As Integer              '==シート数

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

  

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

    intShtName_Su = 0

    For intLoop = 1 To obj対象ブック.Worksheets.Count

        intShtName_Su = intShtName_Su + 1

        strShtName(intShtName_Su) = obj対象ブック.Worksheets(intLoop).Name

    Next

'

'***シート一覧という名のシートが既にあるか調査

    intShAri = 0

    For intLoop = 1 To intShtName_Su

        If strShtName(intLoop) = "シート一覧" Then

           intShAri = 1

        End If

    Next

'

'***シートを追加

    If intShAri = 1 Then                                                          '==シート一覧というシートが既にあれば中身を消す

       obj対象ブック.Worksheets("シート一覧").Cells = ""

    Else

       obj対象ブック.Worksheets.Add BEFORE:=obj対象ブック.Worksheets(1)           '==シート一覧というシートを追加

       obj対象ブック.ActiveSheet.Name = "シート一覧"

    End If

'

'***タイトル

    lng設定行 = 1

    obj対象ブック.Worksheets("シート一覧").Cells(lng設定行, 1) = "シート一覧:シート名クリックで表示"

'

'***シート一覧の作成

    For intLoop = 1 To intShtName_Su

        strShtNm = strShtName(intLoop)

        If strShtNm <> "シート一覧" Then

           lng設定行 = lng設定行 + 1

           strRange = "A" & Format$(lng設定行, "#0")

           strAddress = ""                                                      '==同じブックのシート一覧というシートに設定するのでここは無指定

           strSubAddress = "'" & strShtNm & "'!A1"

           strDisplay = strShtNm

           obj対象ブック.Worksheets("シート一覧").Range(strRange).Hyperlinks.Add Anchor:=obj対象ブック.Worksheets("シート一覧").Range(strRange), Address:=strAddress, SubAddress:=strSubAddress, TextToDisplay:=strDisplay

           obj対象ブック.Worksheets("シート一覧").Range(strRange).Font.Size = 11    '==少し文字が小さくなるので大きめに

        End If

    Next

'

'***幅設定

    obj対象ブック.Worksheets("シート一覧").Cells.EntireColumn.AutoFit

'

'***EXIT

    Exit Sub

End Sub

  

テスト用メインです

Sub TestMain()

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

'@ SP8600_ShtItiCreのテスト用メイン

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

Dim strBookPath As String

Dim obj対象ブック As Object      '==ブックオブジェクト

'

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

    strBookPath = ThisWorkbook.Sheets(1).Range("DataPath")

    If strBookPath = "" Then

       MSGBOX "TEST用データブックを指定して下さい"

       Exit Sub

    End If

'

'***TEST用ブックOPEN

    Set obj対象ブック = Workbooks.Open(FileName:=strBookPath)

'

'***CALL

    Call SP8600_ShtItiCre(obj対象ブック)

'

'***後始末

    Set obj対象ブック = Nothing

'

'*** EXIT

    Exit Sub

End Sub