ブック

＜インデックス＞

INDEX

INDEXリンク

＜その他＞

＜インデックス＞

INDEX

Sub ブック_INDEX()        'シートのINDEXを作成する。        Dim s As Worksheet    Dim i As Integer        Dim w_sheet As Worksheet        '■■■■■■■■■■■■■■■■■    Application.DisplayAlerts = False    Application.EnableEvents = False    Application.ScreenUpdating = False    Application.Calculation = xlCalculationManual    '■■■■■■■■■■■■■■■■■        On Error Resume Next    Sheets("INDEX").Delete    On Error GoTo 0            Sheets.Add Before:=Sheets(1)    Set s = ActiveSheet    s.Name = "INDEX"        s.Cells.ColumnWidth = 2        i = 1            For Each w_sheet In Sheets                    Application.StatusBar = "ハイパーリンク作成 " & i & "/" & Sheets.Count                    s.Cells(i, 1) = w_sheet.Index                s.Cells(i, 2) = "'" & w_sheet.Name        ActiveSheet.Hyperlinks.Add _            Anchor:=s.Cells(i, 2), Address:="", SubAddress:="'" & s.Cells(i, 2).Value & "'!A1", TextToDisplay:="'" & s.Cells(i, 2).Value                If w_sheet.Visible = xlSheetHidden Then            s.Cells(i, 2).Interior.ColorIndex = 15 '灰色        End If                s.Cells(i, 3).Value = w_sheet.Cells.SpecialCells(xlCellTypeLastCell).row        s.Cells(i, 4).Value = w_sheet.Cells.SpecialCells(xlCellTypeLastCell).Column                i = i + 1        Next w_sheet        For Each w_sheet In Sheets                    If w_sheet.Name <> "INDEX" Then            w_sheet.Activate            If w_sheet.Range("A1") = "※" Then                w_sheet.Range("A1") = ""            End If            w_sheet.Range("A1").Select        End If                i = i + 1        Next w_sheet        Sheets("INDEX").Activate    For Each w_sheet In Sheets                    w_sheet.Activate        ActiveWindow.LargeScroll ToLeft:=99        ActiveWindow.LargeScroll Up:=99        w_sheet.Range("A1").Select            Next w_sheet
    With Sheets("INDEX")        .Range("C1").Value = "行数"        .Range("D1").Value = "列数"    End With
    s.Activate    s.Cells.Font.Name = "Meiryo UI"    s.Cells.EntireColumn.AutoFit        Rows("2:2").Select    ActiveWindow.FreezePanes = True    Columns("B:B").Select    Selection.AutoFilter        s.Cells(1, 1).Select
    '■■■■■■■■■■■■■■■■■    Application.Calculation = xlCalculationAutomatic    Application.ScreenUpdating = True    Application.EnableEvents = True    Application.DisplayAlerts = True    Application.StatusBar = False    '■■■■■■■■■■■■■■■■■
End Sub

INDEXリンク

Sub ブック_INDEXリンク作成()        Range("A1").Select    ActiveCell.FormulaR1C1 = "※"    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="INDEX!A1", TextToDisplay:="※"    If Selection.Interior.Pattern <> xlNone Then '無        With Selection.Font            .ThemeColor = xlThemeColorDark1            .TintAndShade = 0        End With    End If
    If Range("A2").Value = "(LINK)" Then        Range("A2").Value = ""    End If        If Range("B1") = "" Then        Range("B1") = ActiveSheet.name    End If
    ActiveSheet.Range("A1").HorizontalAlignment = xlGeneral    ActiveSheet.Columns(1).AutoFit        ActiveSheet.Rows("3:3").Select    ActiveWindow.FreezePanes = False    ActiveWindow.FreezePanes = True    ActiveSheet.Range("A1").Select                End Sub

＜その他＞

ブックを非表示にする

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error Resume Next Workbooks(ThisWorkbook.Name).Windows(1).Visible = False On Error GoTo 0
End Sub

ブックのリンクを削除

Sub RemoveWorkbookLinks() Dim wb As Workbook Dim linkArray As Variant Dim i As Integer ' アクティブなブックを設定 Set wb = ActiveWorkbook ' ブック内のリンクを取得 linkArray = wb.LinkSources(Type:=xlLinkTypeExcelLinks) ' リンクが存在する場合 If Not IsEmpty(linkArray) Then For i = LBound(linkArray) To UBound(linkArray) ' リンクを解除 wb.BreakLink Name:=linkArray(i), Type:=xlLinkTypeExcelLinks Next i End IfEnd Sub

シート名編集

Sub ブック_シート名編集()
    '「INDEX」シートのC列から、シート名を編集します。
    Dim s As Worksheet    Dim r_end As Integer    Dim i As Integer
    On Error Resume Next    Sheets("INDEX").Select    If Err.Number <> 0 Then        MsgBox "「INDEX」シートを作成してください。"        Exit Sub    End If    On Error GoTo 0
    Set s = ActiveSheet    With s.UsedRange        r_end = .Row + .Rows.Count - 1    End With        For i = 1 To r_end        If s.Cells(i, 3).Value <> "" Then            Sheets(s.Cells(i, 1).Value).Name = s.Cells(i, 3).Value        End If    Next i
End Sub

シート表示

Sub ブック_シート表示() Dim w_sheet As Worksheet For Each w_sheet In ActiveWorkbook.Sheets w_sheet.Visible = True Next w_sheet End Sub

ウインドウ枠の固定2行目

Sub ブック_ウインドウ枠の固定2行目()
Application.EnableEvents = False For Each w_sheet In Sheets Application.StatusBar = "ハイパーリンク作成 " & i & "/" & Sheets.Count If w_sheet.Visible = xlSheetVisible Then If w_sheet.name <> "INDEX" Then w_sheet.Activate If w_sheet.Range("A1") = "" Or w_sheet.Range("A1") = "※" Or w_sheet.Range("A1") = "INDEX" Then ActiveWindow.FreezePanes = False w_sheet.Rows("1:1").Select w_sheet.Rows("3:3").Select ActiveWindow.FreezePanes = True w_sheet.Range("A1").Select End If Sheets("INDEX").Activate End If End If i = i + 1 Next w_sheet Application.EnableEvents = True
End Sub

シート並び替え

Sub ブック_シート並び替え()
    Dim w_sheet As Worksheet    Dim s As Worksheet    Dim i As Integer    Dim r_end As Integer
    On Error Resume Next    Worksheets("INDEX").Select    If Err.Number <> 0 Then        MsgBox ("「INDEX」シートがありません。")        Exit Sub    End If    On Error GoTo 0
    Set s = ActiveSheet    With s.UsedRange        r_end = .Row + .Rows.Count - 1    End With
    On Error Resume Next    For i = 1 To r_end        Sheets(s.Cells(i, 2).Value).Move After:=Sheets(Sheets.Count)        s.Cells(i, 1).Value = i        If Err.Number <> 0 Then            s.Select            s.Cells(i, 2).Select            MsgBox ("「INDEX」シートが最新ではありません。")            Exit Sub        End If    Next i    On Error GoTo 0        If Sheets.Count <> r_end Then        MsgBox ("「INDEX」シートが最新ではありません。")    End If
    Sheets(1).Activate
End Sub

名前全表示

Sub ブック_名前全表示()
    Dim name As Object
    For Each name In Names        If name.Visible = False Then            name.Visible = True        End If    Next
    MsgBox "すべての名前の定義を表示しました。", vbOKOnly
End Sub

見出し

Sub ブック_見出し()
    '選択範囲から、見出しシートを作成
    Dim s As Worksheet    Dim s0 As Worksheet
    Dim w_cell As Range    Dim w_selection As Range
    Dim x As Integer    Dim row_bk As Integer
    Application.DisplayAlerts = False        Set s0 = ActiveSheet    Set w_selection = Selection        On Error Resume Next    Sheets("見出し").Delete    On Error GoTo 0        Sheets.Add before:=Sheets(1)    Set s = ActiveSheet    s.Name = "見出し"
    x = 0    row_bk = 0    For Each w_cell In w_selection.Cells        If w_cell.Value <> "" Then            If row_bk <> w_cell.Row Then                x = x + 1            End If            s.Cells(x, w_cell.Column).Value = w_cell.Value            ActiveSheet.Hyperlinks.Add Anchor:=s.Cells(x, w_cell.Column), Address:="", SubAddress:="'" & s0.Name & "'!" & w_cell.Address, _ TextToDisplay:="'" & s.Cells(x, w_cell.Column).Value            row_bk = w_cell.Row        End If    Next w_cell
    s.Cells.EntireColumn.AutoFit    s.Columns(1).ColumnWidth = 2
    Application.DisplayAlerts = True
End Sub

A1選択

Sub ブック_A1選択() '全シートのA1を選択する。 Dim w_sheet As Worksheet Application.DisplayAlerts = False Application.ScreenUpdating = True Application.EnableEvents = True For Each w_sheet In Sheets w_sheet.Activate ActiveWindow.LargeScroll ToLeft:=99 ActiveWindow.LargeScroll Up:=99 w_sheet.Range("A1").Select Next w_sheet Application.DisplayAlerts = True Application.StatusBar = False Sheets(1).Activate End Sub

名前表示

Sub ブック_名前表示() '非表示になっている名前を表示する Dim name As Object For Each name In Names If name.Visible = False Then name.Visible = True End If Next MsgBox "すべての名前の定義を表示しました。", vbOKOnly End Sub

入力規則削除

Sub ブック_入力規則削除()
Dim ws As Worksheet If MsgBox("全シートの入力規則を削除しますか？", vbYesNo) = vbNo Then Exit Sub End If For Each ws In Worksheets ws.Cells.Validation.Delete Next ws
End Sub