ブック

＜インデックス＞

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 = 2    For Each w_sheet In Sheets                    s.Cells(i, 1) = w_sheet.Index                s.Cells(i, 3) = "'" & w_sheet.Name        ActiveSheet.Hyperlinks.Add Anchor:=s.Cells(i, 3), Address:="", SubAddress:="'" & s.Cells(i, 3).Value & "'!A1", TextToDisplay:="'" & s.Cells(i, 3).Value        s.Cells(i, 3).Font.Underline = xlUnderlineStyleNone
        If w_sheet.Visible = xlSheetHidden Then            s.Cells(i, 3).Interior.ColorIndex = 15 '灰色        End If                s.Cells(i, 5).Value = w_sheet.Cells.SpecialCells(xlCellTypeLastCell).row        s.Cells(i, 6).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            w_sheet.Range("A1").Select        End If                i = i + 1        Next w_sheet    ' Dim topM As Double, bottomM As Double, leftM As Double, rightM As Double' Dim headerM As Double, footerM As Double'' topM = Application.CentimetersToPoints(2)' bottomM = Application.CentimetersToPoints(1)' leftM = Application.CentimetersToPoints(1)' rightM = Application.CentimetersToPoints(1)' headerM = Application.CentimetersToPoints(1)' footerM = Application.CentimetersToPoints(0.5)            Sheets("INDEX").Activate    For Each w_sheet In Sheets                    w_sheet.Select                Application.StatusBar = w_sheet.Name        DoEvents                ActiveWindow.LargeScroll ToLeft:=99        ActiveWindow.LargeScroll Up:=99                With w_sheet.PageSetup            .Zoom = False            .FitToPagesWide = 1            .FitToPagesTall = 1        End With    ' With w_sheet.PageSetup'' .LeftHeader = "&F"' .CenterHeader = "&A"' .RightHeader = "ページ &P"'' .TopMargin = topM' .BottomMargin = bottomM' .LeftMargin = leftM' .RightMargin = rightM' .HeaderMargin = headerM' .FooterMargin = footerM'' End With        Next w_sheet
    Application.StatusBar = "印刷設定中"    DoEvents        Dim ws As Worksheet    Dim arr()    Dim i1 As Long        '--- 全シート名を配列に格納 ---    ReDim arr(1 To ActiveWorkbook.Worksheets.Count)    For i1 = 1 To ActiveWorkbook.Worksheets.Count        arr(i1) = ActiveWorkbook.Worksheets(i1).Name    Next i1        '--- 全シートを一括選択 ---    ActiveWorkbook.Worksheets(arr).Select        '--- 印刷設定を一発で適用 ---    Dim topM As Double, bottomM As Double, leftM As Double, rightM As Double    Dim headerM As Double, footerM As Double
    topM = Application.CentimetersToPoints(2)    bottomM = Application.CentimetersToPoints(1)    leftM = Application.CentimetersToPoints(1)    rightM = Application.CentimetersToPoints(1)    headerM = Application.CentimetersToPoints(1)    footerM = Application.CentimetersToPoints(0.5)            With ActiveSheet.PageSetup
        .Orientation = xlLandscape        .PaperSize = xlPaperA4        .Zoom = False        .FitToPagesWide = 1        .FitToPagesTall = False                .LeftHeader = "&F"        .CenterHeader = "&A"        .RightHeader = "ページ &P"
        .TopMargin = topM        .BottomMargin = bottomM        .LeftMargin = leftM        .RightMargin = rightM        .HeaderMargin = headerM        .FooterMargin = footerM
' .CenterHorizontally = True        End With        '--- 最初のシートだけ選択状態に戻す ---    Worksheets(arr(1)).Select
    Dim ws1 As Worksheet    Dim totalPages As Long    Dim thisPages As Long        totalPages = 1 '最初のシートは1ページ目から        Dim x As Integer    x = 2    For Each ws1 In ActiveWorkbook.Worksheets                'シートの印刷ページ数を取得        thisPages = ws1.PageSetup.Pages.Count                '開始ページ番号をに書き込む        s.Range("D" & x).Value = totalPages        x = x + 1                '累積ページを更新        totalPages = totalPages + thisPages            Next ws1        With s                .Range("A1").Value = "№"        .Range("A1").HorizontalAlignment = xlRight        .Range("C1").Value = "シート"        .Range("D1").Value = "ページ"        .Range("D1").HorizontalAlignment = xlRight        .Range("E1").Value = "行数"        .Range("F1").Value = "列数"        .Tab.ColorIndex = 3        .PageSetup.PrintArea = "A1:D" & .UsedRange.Rows.Count            End With
    s.Activate    s.Cells.Font.Name = "Meiryo UI"    s.Cells.EntireColumn.AutoFit        Rows("2:2").Select    ActiveWindow.FreezePanes = True    Columns("C:C").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