シート一括生成 

リンク付きシート生成マクロ version1.0

1シート目に記載したシート一覧からその名称でシートを作成する。
リンクを付与し、1シート目に移動する関数も用意したことでシート移動が容易になる。
また、シートの生成は存在しなかったときのみで、すでに存在している場合はリンクの付与と順序の再設定を行う(一覧準拠)。
表の内容に合わせて適宜ソースを修正すること(主にシート名の列指定)。
リンクを一括削除するメソッドも用意しているので、こちらも適宜使用されたし。

'シート名表に合わせてシートを生成する。表からリンクできる
Sub createSheetsWithLink()
    Dim topSheet As Worksheet
    Set topSheet = Sheets(1)
    
    Dim lastRowToBottom As Integer: lastRowToBottom = topSheet.Cells(1, 1).End(xlDown).ROW
    
    Dim sheetName As String
    Dim linkRange As Range

    For i = 2 To lastRowToBottom
        sheetName = topSheet.Cells(i, 2).Value
        Set linkRange = topSheet.Cells(i, 2)
        
        If Not existsSheet(sheetName) Then
            'シートが存在していない場合
            With Worksheets.Add(after:=ActiveSheet)
                .Name = sheetName
                topSheet.Hyperlinks.Add Anchor:=linkRange, Address:="", SubAddress:=.Name & "!A1"
                .Select
            End With
        Else
            '既にある場合
            topSheet.Hyperlinks.Add Anchor:=linkRange, Address:="", SubAddress:=sheetName & "!A1"
            Sheets(sheetName).Select
            'シート順の並び変え
            If existsSheet(topSheet.Cells(i - 1, 1)) Then
                'ここ、シート名の指定に「.value」が必要
                Sheets(sheetName).Move after:=Sheets(topSheet.Cells(i - 1, 1).Value)
            End If
        End If
    Next
    
    topSheet.Select
End Sub

'最初のシートを選択する
Sub selectFirstSheet()
    Sheets(1).Select
End Sub

'指定した行のリンクを解除する
Sub deleteLink()
    Dim topSheet As Worksheet
    Set topSheet = Sheets(1)
    
    Dim lastRowToBottom As Integer: lastRowToBottom = topSheet.Cells(1, 1).End(xlDown).ROW
    
    For i = 2 To lastRowToBottom
        topSheet.Cells(i, 2).Hyperlinks.Delete
    Next
End Sub

'指定したシートの全リンクを解除する
Sub deleteLinkInAllRange()
    Sheets(1).Hyperlinks.Delete
End Sub

'シートが存在するかどうか
Function existsSheet(ByVal sheetName As String)
    Dim ws As Variant
    For Each ws In Sheets
        If LCase(ws.Name) = LCase(sheetName) Then
            existsSheet = True
            Exit Function
        End If
    Next

    ' 存在しない
    existsSheet = False
End Function

TODO:新規シートを生成する、という形になっているので、もうひとつ亜種としてひな型シートをコピーする、というパターンも作りたい。

関連記事:目次シート作成



コメント