便利小工具的VBA写法

<<ThisWorkBook>>这个文档内容

Public Sub Workbook_Open()

    Call CreateToolBar.CreateToolBar

End Sub

<<MoDules>>这个文档内容建一个名为CreateToolBar的module

Option Explicit

Sub CreateToolBar()

    Dim newTool As CommandBar

    On Error Resume Next

    Application.CommandBars("CDC_KANDEN_TOOLBAR").Delete

    On Error GoTo 0

    Application.CommandBars.Add

    Set newTool = Application.CommandBars.Add(Name:="CDC_KANDEN_TOOLBAR")

    newTool.Visible = True

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetToA1"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 10

        .OnAction = "SetToA1"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetFont"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 401

        .OnAction = "SetFont"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetZoom70"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 25

        .OnAction = "SetZoom70"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetPrintAreaE"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 84

        .OnAction = "SetPrintAreaE"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetHeaderLink"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 43

        .OnAction = "SetHeaderLink"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetHeaderSize"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 326

        .OnAction = "SetHeaderSize"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetColomnSize"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 970

        .OnAction = "SetColomnSize"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SetScrollBar"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 468

        .OnAction = "SetScrollBar"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "ResetFormatAll"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 105

        .OnAction = "ResetFormatAll"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "OpenFile"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 23

        .OnAction = "OpenFile"

    End With

    With newTool.Controls.Add(Type:=msoControlButton)

        .Caption = "SortByCustom"

        .Style = msoButtonIcon

        .TooltipText = "TooltipText"

        .FaceId = 210

        .OnAction = "SortByCustom"

    End With

End Sub

Sub CreateFaceIdToolBar()

    Dim newTool As CommandBar

    On Error Resume Next

    Application.CommandBars("FaceIdToolbar").Delete

    On Error GoTo 0

    Application.CommandBars.Add

    Set newTool = Application.CommandBars.Add(Name:="FaceIdToolbar")

    newTool.Visible = True

    Dim i As Integer

    For i = 15 To 30

        With newTool.Controls.Add(Type:=msoControlButton)

            .Caption = i

            .Style = msoButtonIconAndCaption

            .FaceId = i

        End With

    Next

End Sub

<<MoDules>>这个文档内容建一个名为OnAction的module

Option Explicit

Sub SetToA1()

    Dim sh As Worksheet

    Dim btn As Long

    btn = MsgBox("カーソルの位置を「A1」に移動してよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If btn = vbYes Then

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            Call SetToA1OfOneSheet

        Next

        Sheets(1).Activate

        Application.ScreenUpdating = True

    End If

    If btn = vbNo Then

        Call SetToA1OfOneSheet

    End If

    Set sh = Nothing

    MsgBox ("Finished")

End Sub

Sub SetFont()

    Dim currSheet As Worksheet

    Dim sh As Worksheet

    Dim btn As Long

    btn = MsgBox("フォントは「Meiryo UI」を設定してよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If btn = vbYes Then

        Set currSheet = ActiveSheet

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            Call SetFontOfOneSheet

            Call SetObjectFontOfOneSheet

        Next

        Application.ScreenUpdating = True

        currSheet.Select

    End If

    If btn = vbNo Then

        Call SetFontOfOneSheet

        Call SetObjectFontOfOneSheet

    End If

    Set currSheet = Nothing

    Set sh = Nothing

    MsgBox ("Finished")

End Sub

Sub SetZoom70()

    Dim currSheet As Worksheet

    Dim sh As Worksheet

    Dim btn As Long

    btn = MsgBox("ズームを「70％」に設定してよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If btn = vbYes Then

        Set currSheet = ActiveSheet

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            Call SetZoom70OfOneSheet

        Next

        Application.ScreenUpdating = True

        currSheet.Select

    End If

    If btn = vbNo Then

        Call SetZoom70OfOneSheet

    End If

    Set currSheet = Nothing

    Set sh = Nothing

    MsgBox ("Finished")

End Sub

Sub SetPrintAreaE()

    Dim currSheet As Worksheet

    Dim sh As Worksheet

    Dim btn As Long

    btn = MsgBox("印刷範囲の外側に「e」を付けてよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If btn = vbYes Then

        Set currSheet = ActiveSheet

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            Call SetPrintAreaEOfOneSheet

        Next

        Application.ScreenUpdating = True

        currSheet.Select

    End If

    If btn = vbNo Then

        Call SetPrintAreaEOfOneSheet

    End If

    Set currSheet = Nothing

    Set sh = Nothing

    MsgBox ("Finished")

End Sub

Sub SetHeaderLink()

    Dim currSheet As Worksheet

    Dim sh As Worksheet

    Dim btn As Long

    Dim allAddress() As String

    btn = MsgBox("ヘッダ情報を反映してよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If Sheets.Count = 1 Then

        MsgBox ("１シートのみ存在していますので、処理中止します。")

        Exit Sub

    End If

    allAddress = GetHeaderLinkAddress

    If btn = vbYes Then

        Set currSheet = ActiveSheet

        Dim cnt As Integer

        cnt = 1

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            If sh.Name <> Sheets(1).Name Then

                Dim sheetFrom As Worksheet

                Dim startAddressFrom As String

                Dim endAddressFrom As String

                Dim sheetTo As Worksheet

                Dim startAddressTo As String

                Dim endAddressTo As String

                If cnt = 1 Then

                    Call SetHeaderLinkOfOneSheet(allAddress(0), allAddress(1), allAddress(2), allAddress(3), allAddress(4), allAddress(5), allAddress(6), allAddress(7), allAddress(8), allAddress(9))

                    Set sheetFrom = ActiveSheet

                    startAddressFrom = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").address(0, 0)

                    endAddressFrom = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Offset(1, 0).address(0, 0)

                End If

                If cnt >= 2 Then

                    Set sheetTo = ActiveSheet

                    startAddressTo = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").address(0, 0)

                    endAddressTo = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Offset(1, 0).address(0, 0)

                End If

                If cnt = 2 Then

                    sheetFrom.Activate

                    sheetFrom.Range(startAddressFrom & ":" & endAddressFrom).Select

                    Selection.Copy

                End If

                If cnt >= 2 Then

                    sheetTo.Activate

                    ActiveSheet.Range(startAddressTo & ":" & endAddressTo).Select

                    ActiveSheet.Paste

                End If

                cnt = cnt + 1

            End If

        Next

        Application.ScreenUpdating = True

        currSheet.Select

    End If

    If btn = vbNo Then

        If ActiveSheet.Name <> Sheets(1).Name Then

            Call SetHeaderLinkOfOneSheet(allAddress(0), allAddress(1), allAddress(2), allAddress(3), allAddress(4), allAddress(5), allAddress(6), allAddress(7), allAddress(8), allAddress(9))

        Else

            MsgBox ("「" & Sheets(1).Name & "」以外のシートを選択してください。")

        End If

    End If

    Set currSheet = Nothing

    Set sh = Nothing

    MsgBox ("Finished")

End Sub

Sub SetHeaderSize()

    Dim currSheet As Worksheet

    Dim sh As Worksheet

    Dim btn As Long

    Dim allAddress() As String

    btn = MsgBox("全シートのヘッダオブジェクトのサイズを統一してよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If Sheets.Count = 1 Then

        MsgBox ("１シートのみ存在していますので、処理中止します。")

        Exit Sub

    End If

    Set currSheet = ActiveSheet

    Dim firstSheet As Worksheet

    Dim left As Single, top As Single, width As Single, height As Single

    Set firstSheet = Sheets(1)

    firstSheet.Activate

    Dim shp As Shape

    For Each shp In firstSheet.Shapes

        shp.Select

        Dim formula As String

        On Error Resume Next

        formula = Selection.formula

        On Error GoTo 0

        If formula <> "" Then

            With Selection.ShapeRange

                left = .left

                top = .top

                width = .width

                height = .height

            End With

            Exit For

        End If

    Next shp

    currSheet.Select

    If btn = vbYes Then

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            If sh.Name <> Sheets(1).Name Then

                Call SetHeaderSizeOfOneSheet(left, top, width, height)

            End If

        Next

        Application.ScreenUpdating = True

        currSheet.Select

    End If

    If btn = vbNo Then

        If ActiveSheet.Name <> Sheets(1).Name Then

            Call SetHeaderSizeOfOneSheet(left, top, width, height)

        Else

            MsgBox ("「" & Sheets(1).Name & "」以外のシートを選択してください。")

        End If

    End If

    Set currSheet = Nothing

    Set sh = Nothing

    Set firstSheet = Nothing

    MsgBox ("Finished")

End Sub

Sub SetColomnSize()

    Dim currSheet As Worksheet

    Dim sh As Worksheet

    Dim btn As Long

    btn = MsgBox("列の幅を調整してよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If btn = vbYes Then

        Set currSheet = ActiveSheet

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            Call SetColomnSizeOfOneSheet

        Next

        Application.ScreenUpdating = True

        currSheet.Select

    End If

    If btn = vbNo Then

        Call SetColomnSizeOfOneSheet

    End If

    Set currSheet = Nothing

    Set sh = Nothing

    MsgBox ("Finished")

End Sub

Sub SetScrollBar()

    Dim currSheet As Worksheet

    Dim sh As Worksheet

    Dim btn As Long

    btn = MsgBox("スクロールバーを初期化してよろしいでしょうか？" & vbCrLf & vbCrLf & _

            "全シート：「はい」を押してください。" & vbCrLf & _

            "当シート：「いいえ」を押してください。" & vbCrLf, _

            vbYesNoCancel)

    If btn = vbCancel Then

        Exit Sub

    End If

    If btn = vbYes Then

        Set currSheet = ActiveSheet

        Application.ScreenUpdating = False

        For Each sh In Sheets

            sh.Activate

            Call SetScrollBarOfOneSheet

        Next

        Application.ScreenUpdating = True

        currSheet.Select

    End If

    If btn = vbNo Then

        Call SetScrollBarOfOneSheet

    End If

    Set currSheet = Nothing

    Set sh = Nothing

    MsgBox ("Finished")

End Sub

Sub OpenFile()

    Dim selectItem As Variant

    With Application.FileDialog(msoFileDialogFilePicker)

        .AllowMultiSelect = True

        .Filters.Clear

        .Filters.Add "Excel Files", "*.xlsx;*.xlsm"

        If .Show = -1 Then

            For Each selectItem In .SelectedItems

                Workbooks.Open fileName:=selectItem, Password:="kanden"

            Next

        End If

    End With

End Sub

Sub SortByCustom()

    Dim range1 As Range

    Dim range2 As Range

    Dim range3 As Range

    Dim rangex As Range

    Dim x

    Dim strArray() As String

    Dim i As Integer

    On Error Resume Next

    On Error GoTo 0

    Set x = Application.InputBox("基準を選択してください。", "範囲選択", Type:=8)

    If VarType(x) = vbBoolean Then

        Exit Sub

    End If

    Set range1 = x

    Set x = Application.InputBox("範囲を選択してください。", "範囲選択", Type:=8)

    If VarType(x) = vbBoolean Then

        Exit Sub

    End If

    Set range2 = x

    Set x = Application.InputBox("キーを選択してください。", "範囲選択", Type:=8)

    If VarType(x) = vbBoolean Then

        Exit Sub

    End If

    Set range3 = x

    i = 0

    ReDim strArray(range1.Count - 1)

    For Each rangex In range1

        strArray(i) = rangex.Value

        i = i + 1

    Next

    ActiveSheet.sort.SortFields.Clear

    ActiveSheet.sort.SortFields.Add Key:=range3, _

    SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Join(strArray, ","), DataOption:=xlSortTextAsNumbers

    With ActiveSheet.sort

        .SetRange range2

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    MsgBox ("Finished")

End Sub

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

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

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

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

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

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

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

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

Sub SetToA1OfOneSheet()

    Application.Goto ActiveSheet.Cells(1, 1), True

End Sub

Sub SetFontOfOneSheet()

    Cells.Font.Name = "Meiryo UI"

End Sub

Sub SetObjectFontOfOneSheet()

    Dim shp As Shape

    For Each shp In ActiveSheet.Shapes

        shp.Select

        On Error Resume Next

        With Selection.ShapeRange.TextFrame2.TextRange.Font

            .NameComplexScript = "Meiryo UI"

            .NameFarEast = "Meiryo UI"

            .Name = "Meiryo UI"

        End With

        On Error GoTo 0

    Next shp

End Sub

Sub SetZoom70OfOneSheet()

    ActiveWindow.Zoom = 70

End Sub

Sub SetPrintAreaEOfOneSheet()

    '開始行

    Dim startRow As Long

    '最終行

    Dim lastRow As Long

    '開始列

    Dim startCol As Long

    '最終列

    Dim lastCol As Long

    With Range(ActiveSheet.PageSetup.PrintArea)

        '印刷範囲の開始行、最終行を取得

        startRow = .Rows.Row

        lastRow = startRow + .Rows.Count

        '印刷範囲の開始列、最終列を取得

        startCol = .Columns.Column

        lastCol = startCol + .Columns.Count

    End With

    ActiveSheet.Range(ActiveSheet.Cells(lastRow, startCol), ActiveSheet.Cells(lastRow, lastCol)).Value = "e"

    ActiveSheet.Range(ActiveSheet.Cells(startRow, lastCol), ActiveSheet.Cells(lastRow, lastCol)).Value = "e"

End Sub

Function GetHeaderLinkAddress() As String()

    Dim deliverAddress As String

    Dim detailAddress As String

    Dim projectIdAddress As String

    Dim teamAddress As String

    Dim identifierAddress As String

    Dim updaterAddress As String

    Dim authorizerAddress As String

    Dim updatedDayAddress As String

    Dim approvalDayAddress As String

    Dim address(9) As String

    Dim sh As Worksheet

    Set sh = Sheets(1)

    deliverAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("成果物名").Offset(0, 1).address(0, 0)

    detailAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("詳細").Offset(0, 1).address(0, 0)

    projectIdAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("プロジェクト文章ID").Offset(0, 1).address(0, 0)

    teamAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("チーム分類").Offset(0, 1).address(0, 0)

    identifierAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("文章識別子").Offset(0, 1).address(0, 0)

    updaterAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終更新者").Offset(1, 0).address(0, 0)

    authorizerAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終承認者").Offset(1, 0).address(0, 0)

    updatedDayAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終更新日").Offset(1, 0).address(0, 0)

    approvalDayAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終承認日").Offset(1, 0).address(0, 0)

    address(0) = sh.Name

    address(1) = deliverAddress

    address(2) = detailAddress

    address(3) = projectIdAddress

    address(4) = teamAddress

    address(5) = identifierAddress

    address(6) = updaterAddress

    address(7) = authorizerAddress

    address(8) = updatedDayAddress

    address(9) = approvalDayAddress

    GetHeaderLinkAddress = address

    Set sh = Nothing

End Function

Sub SetHeaderLinkOfOneSheet(sheet_name As String _

                            , deliver As String _

                            , detail As String _

                            , projectId As String _

                            , team As String _

                            , identifier As String _

                            , updater As String _

                            , authorizer As String _

                            , updated_day As String _

                            , approval_day As String)

    Dim deliver_row As Integer

    Dim deliver_col As Integer

    Dim detail_row As Integer

    Dim detail_col As Integer

    Dim detail_col2 As Integer

    Dim projectId_row As Integer

    Dim projectId_col As Integer

    Dim team_row As Integer

    Dim team_col As Integer

    Dim identifier_row As Integer

    Dim identifier_col As Integer

    Dim updater_row As Integer

    Dim updater_col As Integer

    Dim authorizer_row As Integer

    Dim authorizer_col As Integer

    Dim updated_day_row As Integer

    Dim updated_day_col As Integer

    Dim approval_day_row As Integer

    Dim approval_day_col As Integer

    '成果物名

    deliver_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").Row

    deliver_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").Column

    If deliver_row <> 0 Then

        deliver_col = deliver_col + 7

        ActiveSheet.Cells(deliver_row, deliver_col).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(deliver_row, deliver_col).Value = "='" & sheet_name & "'!" & deliver

    Else

        MsgBox "「成果物名」という文字が見つかりません"

    End If

    '詳細名

    detail_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("詳細").Row

    detail_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("詳細").Column

    If detail_row <> 0 Then

        detail_col = detail_col + 7

        detail_col2 = detail_col + 26

        ActiveSheet.Cells(detail_row, detail_col).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(detail_row, detail_col).Value = "='" & sheet_name & "'!" & detail

        ActiveSheet.Cells(detail_row, detail_col2).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(detail_row, detail_col2).Value = "=MID(CELL(""filename"",$A$2),FIND(""]"",CELL(""filename"",$A$2))+1,31)"

    Else

        MsgBox "「詳細」という文字が見つかりません"

    End If

    'プロジェクト文章ID

    projectId_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("プロジェクト文章ID").Row

    projectId_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("プロジェクト文章ID").Column

    If projectId_row <> 0 Then

        projectId_col = projectId_col + 7

        ActiveSheet.Cells(projectId_row, projectId_col).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(projectId_row, projectId_col).Value = "='" & sheet_name & "'!" & projectId

    Else

        MsgBox "「プロジェクト文章ID」という文字が見つかりません"

    End If

    'チーム分類

    team_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("チーム分類").Row

    team_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("チーム分類").Column

    If team_row <> 0 Then

        team_col = team_col + 7

        ActiveSheet.Cells(team_row, team_col).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(team_row, team_col).Value = "='" & sheet_name & "'!" & team

    Else

        MsgBox "「チーム分類」という文字が見つかりません"

    End If

    '文章識別子

    identifier_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("文章識別子").Row

    identifier_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("文章識別子").Column

    If identifier_row <> 0 Then

        identifier_col = identifier_col + 7

        ActiveSheet.Cells(identifier_row, identifier_col).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(identifier_row, identifier_col).Value = "='" & sheet_name & "'!" & identifier

    Else

        MsgBox "「文章識別子」という文字が見つかりません"

    End If

    '最終更新者

    updater_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新者").Row

    updater_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新者").Column

    If updater_row <> 0 Then

        updater_row = updater_row + 1

        ActiveSheet.Cells(updater_row, updater_col).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(updater_row, updater_col).Value = "='" & sheet_name & "'!" & updater

    Else

        MsgBox "「最終更新者」という文字が見つかりません"

    End If

    '最終承認者

    authorizer_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認者").Row

    authorizer_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認者").Column

    If authorizer_row <> 0 Then

        authorizer_row = authorizer_row + 1

        ActiveSheet.Cells(authorizer_row, authorizer_col).NumberFormatLocal = "G/標準"

        ActiveSheet.Cells(authorizer_row, authorizer_col).Value = "='" & sheet_name & "'!" & authorizer

    Else

        MsgBox "「最終承認者」という文字が見つかりません"

    End If

    '最終更新日

    updated_day_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新日").Row

    updated_day_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新日").Column

    If updated_day_row <> 0 Then

        updated_day_row = updated_day_row + 1

        ActiveSheet.Cells(updated_day_row, updated_day_col).NumberFormatLocal = "yyyy/mm/dd"

        ActiveSheet.Cells(updated_day_row, updated_day_col).Value = "='" & sheet_name & "'!" & updated_day

    Else

        MsgBox "「最終更新日」という文字が見つかりません"

    End If

    '最終承認日

    approval_day_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Row

    approval_day_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Column

    If approval_day_row <> 0 Then

        approval_day_row = approval_day_row + 1

        ActiveSheet.Cells(approval_day_row, approval_day_col).NumberFormatLocal = "yyyy/mm/dd"

        ActiveSheet.Cells(approval_day_row, approval_day_col).Value = "='" & sheet_name & "'!" & approval_day

    Else

        MsgBox "「最終承認日」という文字が見つかりません"

    End If

End Sub

Sub SetHeaderSizeOfOneSheet(left As Single, top As Single, width As Single, height As Single)

    '全シートループ

    Dim adjusted As Boolean

    Dim formula As String

    '位置未調整

    adjusted = False

    Dim shp As Shape

    For Each shp In ActiveSheet.Shapes

        shp.Select

        On Error Resume Next

        formula = Selection.formula

        On Error GoTo 0

        If formula <> "" Then

            ' 位置調整

            With Selection.ShapeRange

                .lockAspectRatio = msoFalse

                .height = height

                .width = width

                .left = left

                .top = top

            End With

            '位置調整済

            adjusted = True

        End If

        '位置調整済なら、オートシェイプのループを抜ける

        If adjusted = True Then

            Exit For

        End If

    Next shp

End Sub

Sub SetColomnSizeOfOneSheet()

    If ActiveSheet.Name = "更新履歴" Then

        Columns("A:A").ColumnWidth = 2.38

        Columns("B:B").ColumnWidth = 5.13

        Columns("C:C").ColumnWidth = 50.13

        Columns("D:D").ColumnWidth = 15.63

        Columns("E:E").ColumnWidth = 40.13

        Columns("F:F").ColumnWidth = 15.63

        Columns("G:G").ColumnWidth = 40.13

        Columns("H:H").ColumnWidth = 4.5

        Columns("I:I").ColumnWidth = 8.25

        Columns("J:J").ColumnWidth = 8.25

        Range(Columns("K:K"), Columns("AC:AC").End(xlToRight)).ColumnWidth = 2

    Else

        Columns("A:A").ColumnWidth = 1.88

        Columns("B:AB").ColumnWidth = 8.25

        Range(Columns("AC:AC"), Columns("AC:AC").End(xlToRight)).ColumnWidth = 2

    End If

End Sub

Sub SetScrollBarOfOneSheet()

    '開始行

    Dim startRow As Long

    '最終行

    Dim lastRow As Long

    Dim updatedDayAddress As String

    With Range(ActiveSheet.PageSetup.PrintArea)

        '印刷範囲の開始行、最終行を取得

        startRow = .Rows.Row

        lastRow = startRow + .Rows.Count

    End With

    updatedDayAddress = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新日").Offset(0, 2).address(0, 0)

    updatedDayAddress = Mid(updatedDayAddress, 1, 2)

    Rows(lastRow + 1 & ":" & "1048576").Delete Shift:=xlUp

    Columns(updatedDayAddress & ":" & "XFD").Delete Shift:=xlToLeft

End Sub

Sub ResetFormatAll()

    Dim i As Integer

    Dim j As Integer

    Dim k As Integer

    Dim start_row_number As Integer

    Dim end_row_number As Integer

    Application.ScreenUpdating = False

    start_row_number = Selection.Row

    end_row_number = start_row_number + Selection.Rows.Count - 1

    For i = end_row_number To start_row_number Step -1

        If Cells(i, 2) Like "TABLE=*" Then

            Dim table_end_row_number As Integer

            Dim table_end_column_number As Integer

            table_end_row_number = end_row_number

            table_end_column_number = 16384

            For j = i + 5 To end_row_number

                If Cells(j, 2) = "" Or Cells(j, 2) Like "TABLE=*" Then

                    table_end_row_number = j - 1

                    Exit For

                End If

            Next

            For k = 2 To 16384

                If Cells(i + 2, k) = "" Or Cells(i + 2, k) = "e" Then

                    If Cells(i + 2, k) = "" And Cells(i + 1, k) <> "" Then

                        MsgBox ("漢字名が漏れた")

                        Application.Goto Cells(i + 2, k)

                        Exit Sub

                    End If

                    table_end_column_number = k - 1

                    Exit For

                End If

            Next

            Range(Cells(i, 2), Cells(table_end_row_number, table_end_column_number)).Select

            Call reset_format

        End If

    Next

    MsgBox ("ok")

End Sub

Sub reset_format()

    Dim start_row_number As Integer

    Dim end_row_number As Integer

    Dim start_column_number As Integer

    Dim end_column_number As Integer

    Dim column_count As Integer

    Dim m As Integer

    Dim this_book_nm As String

    Dim this_sheet_nm As String

    start_row_number = Selection.Row

    end_row_number = start_row_number + Selection.Rows.Count - 1

    column_count = Selection.Rows.Count

    start_column_number = Selection.Column

    end_column_number = start_column_number + Selection.Columns.Count - 1

    this_book_nm = ActiveWorkbook.Name

    this_sheet_nm = ActiveSheet.Name

    Selection.Font.Bold = False

    Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Value = Replace(Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Text, "TABLE=", "") & "（" & Replace(Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 4).Text, "//", "") & "）"

    Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Font.Name = "Meiryo UI"

    Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Font.Bold = True

    Workbooks(this_book_nm).Sheets(this_sheet_nm).Range(Cells(start_row_number, 3), Cells(start_row_number, 6)).ClearContents

    Rows((start_row_number + 3) & ":" & (start_row_number + 4)).Delete Shift:=xlUp

    Range(Cells(start_row_number, 2), Cells(end_row_number - 2, end_column_number)).Select

    start_row_number = Selection.Row

    end_row_number = start_row_number + Selection.Rows.Count - 1

    column_count = Selection.Rows.Count

    start_column_number = Selection.Column

    end_column_number = start_column_number + Selection.Columns.Count - 1

    Dim last_row As Integer

    Dim last_column As Integer

    Dim cnt As Integer

    Dim c_au_colunm As Integer

    last_row = start_row_number + 1

    last_column = end_column_number

    cnt = 1

    c_au_colunm = 26

    While last_column > c_au_colunm

        Call insert_blank_rows(last_row + column_count - 1, column_count - 1)

        Call set_many_rows(last_row, c_au_colunm + 1, start_row_number - 1 + cnt * column_count, last_column, start_row_number - 1 + cnt * column_count + 2)

        last_row = start_row_number - 1 + cnt * column_count + 2

        last_column = last_column - c_au_colunm + 1

        cnt = cnt + 1

    Wend

End Sub