VBA: シートへ飛ぶリンクの表示列を可変にしてみました

前回のシートに修正を加えて、リンク一覧の表示列をセルに書いた列に移動できるようにしてみました。実はこれ、ひな形の印刷範囲もコピーされるのでむっちゃ楽なんです。

前回の記事はこちら

で、今回の画面はこちら

リンク一覧の表示列をＰ１セルで調整できるようにしてみました。

実は、これ、わが校の通信簿ファイルに使っているマクロです。

名簿シートから個人シートに一気に飛べるので大変重宝されています。

今回は備忘録として、コードとファイルを載せておきます。

コードは標準モジュールに書きました。

↑コードを書く場所についての過去記事です。

もし興味があれば、触ってみてください。実際に学校現場で使っているマクロです。

【コード】

----------------------------------------------

Option Explicit

Sub ■指定枚数分ひな形シートをコピーしリンク一覧作成()

Dim i As Long
Dim sh As Worksheet
Dim flg As Boolean
Dim makeCnt As Long
Dim rcol As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '手動計算

'作成チェック
For Each sh In Worksheets
　If sh.Name = CStr(1) Then
　　flg = True
　　MsgBox "すでにシートは作成されています"
　　Exit Sub
　End If
Next

If flg = False Then

'★ひな形シートをコピー---------------------------

　makeCnt = Range("K1").Value '作成するシート枚数記入セル

　rcol = Range("P1") '★リンク表列名を入力するセル

'0枚なら抜ける
If makeCnt < 1 Then
　Exit Sub
End If

For i = 1 To makeCnt
　ThisWorkbook.Worksheets("ひな形").Copy After:=Worksheets(Worksheets.Count)
　ActiveSheet.Name = i '★シート名は数字連番をセット
Next

'リンク表削除→作成--------------------
Sheets("index").Activate '★まずindexをアクティブに

Range(Cells(3, rcol), Cells(Rows.Count, rcol).End(xlUp)).ClearContents '★前のリンク表消去
Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp)).ClearContents '★前のナンバーＡ列消去
'★格子罫線削除
Range(Cells(3, 1), ActiveSheet.UsedRange).Borders.LineStyle = xlLineStyleNone

For i = 1 To makeCnt

　'★前のリンク表の右横列消去（左列は手動で削除を！）
　Range(Cells(3, rcol), Cells(Rows.Count, rcol).End(xlUp)).Offset(i - 1, 1).ClearContents

　Range("A" & (i + 2)).Value = i 'Ａ列ナンバー記入
　Range("A" & (i + 1), rcol & (i + 2)).Borders.LineStyle = xlContinuous '格子罫線描画

'リンク表作成
ActiveSheet.Hyperlinks.Add _
anchor:=Cells(i + 2, rcol), _
Address:="", _
SubAddress:=Sheets(CStr(i)).Name & "!" & "E1", _
TextToDisplay:=Sheets(CStr(i)).Name & "番へ飛ぶ"

　'addは、ふつうは、Activesheet
　'Anchor:=リンク一覧を表示するセル位置
　'Address:=ブック内のシートをリンク先にする場合は""
　'★SubAddress:=各シートへのリンクの飛び先アドレス
　'TextToDisplay:=リンクに表示される文字列

Next
'--------------------------------------

　Range(rcol & 2).Value = "リンク一覧" '表示を上書き

End If
Application.Calculation = xlCalculationAutomatic '自動計算に戻す
Application.ScreenUpdating = True

　MsgBox "処理完了"
End Sub

'-----------------------------------------------------

Sub 作成した数字シートを削除する()

Dim sh As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '手動計算

For Each sh In Worksheets
　Application.DisplayAlerts = False '★アラート停止
　If IsNumeric(sh.Name) = True Then '数字シートだけ削除
　　sh.Delete
　End If
　Application.DisplayAlerts = True '★アラート復旧
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic '自動計算に戻す

　MsgBox "処理完了"
End Sub

-----------------------------------------------

今の私にはこのようにしか書けません(^-^;

コードに無駄な部分があるかもしれませんが、快適に動けば別にいいと思っています。

サンプルファイル

↓

 では、また(^^)/