- Microsoft Office 365 Solo(1年版) [オンラインコード] [ダウンロ.../マイクロソフト
- ￥11,800
- Amazon.co.jp
これまで仕様書とか設計書とか作るときにExcelを使うことがなかったのですが、
今の現場ではExcelで作ることも多いらしく、慣例に則って作っていたのですが、、、ふとレビューのとき
「目次作ってね。章ごとにリンク貼って飛べるように。」
ファ！？
テンプレとした元の資料には目次なんか無かったっすけど。。。いや、、、はい。
その時は時間が無かったのと、そこまでの量じゃなかったのでせっせと作りましたが、今後も同じこと言われそうなのでマクロを作っておきました。
やりたいことは大したことではなくてこれだけ
・シートのA列を章タイトルとして使用しているので、空白じゃなければ章としてリンクを作成
・ページ番号をリンクの横に出す
ということでソースは下。
※アメブロってソースきれいに貼れない。。。syntaxhighlighterとか入れたいけどなぁ。。
-----------------------------------------------------
------------------------------------------------------
' 「目次」シート名
Const CONTENTS_PAGE_NAME As String = "目次"
' 目次出力開始位置
Const START_POSITION As String = "B3"
' 目次出力時にクリアする領域
Const OUTPUT_AREA As String = "B:C"
' 見出し検索行数
Const SEARCH_ROW_MAX As Long = 65535
' 目次作成開始
Public Sub CreateContents()
Dim contentsSheetIndex As Integer
contentsSheetIndex = FindWorksheet(CONTENTS_PAGE_NAME)
If contentsSheetIndex >= 0 Then
CreateIndexInner (contentsSheetIndex)
Else
MsgBox "シート名が「目次」のシートを作成してください。", vbOKOnly
End If
End Sub
' シート名でシートを探してIndexを返す
Private Function FindWorksheet(ByVal searchSheetTitle As String) As Integer
Dim result As Integer: result = -1
Dim i As Integer
Dim sheet As Worksheet
For i = 1 To Worksheets.Count
Set sheet = Worksheets(i)
If sheet.Name = searchSheetTitle Then
result = i
Exit For
End If
Next
FindWorksheet = result
End Function
' 目次作成処理
Private Sub CreateIndexInner(ByVal contentsSheetIndex As Integer)
Dim sheetIndex As Integer
Dim contentsSheet, currentSheet As Worksheet
Dim contentsRange, currentRange As Range
Dim i, pageCount As Long
Set contentsSheet = Worksheets(contentsSheetIndex)
Set contentsRange = contentsSheet.Range(START_POSITION)
pageCount = 0
'--- 出力エリアのクリア
contentsSheet.Range(OUTPUT_AREA).Hyperlinks.Delete
contentsSheet.Range(OUTPUT_AREA).Value = ""
For sheetIndex = contentsSheetIndex + 1 To Worksheets.Count
Set currentSheet = Worksheets(sheetIndex)
'--- 見出しのリンクを作成
For i = 1 To SEARCH_ROW_MAX
Set currentRange = currentSheet.Range("A1").Offset(i, 0)
If currentRange.Value <> "" Then
contentsSheet.Hyperlinks.Add Anchor:=contentsRange, Address:="", SubAddress:=(currentSheet.Name & "!" & currentRange.Address), TextToDisplay:=currentRange.Value
contentsRange.Offset(0, 1).Value = pageCount + GetPageNumber(currentRange)
Set contentsRange = contentsRange.Offset(1, 0)
End If
Next
pageCount = pageCount + GetSheetPageCount(sheetIndex)
Next
End Sub
' 指定Rangeが印刷時、何ページ目に印刷されるかを返す
Private Function GetPageNumber(rng As Range) As Long
Dim result As Long
Dim hpb As HPageBreak
Dim vpb As VPageBreak
Dim hCount, vCount As Long
hCount = 0
vCount = 0
For Each hpb In rng.Parent.HPageBreaks
If hpb.Location.Row <= rng.Row Then hCount = hCount + 1
Next
For Each vpb In rng.Parent.VPageBreaks
If vpb.Location.Column <= rng.Column Then vCount = vCount + 1
Next
If rng.Parent.PageSetup.Order = xlDownThenOver Then
'印刷方向が左から右の時
result = vCount * (rng.Parent.HPageBreaks.Count + 1) + hCount + 1
Else
'印刷方向が上から下の時
result = hCount * (rng.Parent.VPageBreaks.Count + 1) + vCount + 1
End If
GetPageNumber = result
End Function
' 指定シートの印刷総ページ数を返す
Private Function GetSheetPageCount(ByVal sheetIndex As Integer)
Dim result As Long
Dim sheet As Worksheet
Set sheet = Worksheets(sheetIndex)
result = (sheet.HPageBreaks.Count + 1) * (sheet.VPageBreaks.Count + 1)
GetSheetPageCount = result
End Function
モジュール作ってペタッとしてください。
「目次」っていうシートを作っておいて、それを目次を作成したいシートの手前に移動して、マクロを実行してください。
A列の検索は65535行でやめちゃったりしてるところとか、出力先とか
適当にいじって使ってください。
一応、動作確認したファイルも置いておきます。
目次自動作成.xlsm
