Option Explicit
Const cWidth = 45
Const addButtonFlag = 1

Sub †シート管理シートを追加()
    Call AddDuggerSheet
    Call writeSheetList_main(False)
End Sub

Sub †シート管理シートを追加_ページ数付()
    Call AddDuggerSheet
    Call writeSheetList_main(True)
End Sub

'†シートを挿入。すでにあれば確認のうえ上書き
Private Sub AddDuggerSheet()
    If Sheets(1).Name = "†" Then
        If MsgBox("シート一覧を更新しますか？", vbOKCancel) = vbCancel Then End
        Application.DisplayAlerts = False
        Sheets(1).Delete
        Application.DisplayAlerts = True
    End If
    Sheets.Add Before:=Sheets(1)
    ActiveSheet.Name = "†"
End Sub

'シート一覧を†シートに書き込み pFlagはページ情報を記載するフラグ
Private Sub writeSheetList_main(Optional pFlag As Boolean = False)
    
    Application.ScreenUpdating = False
    
    'タイトル行の設定
    Cells(1, 1) = "��"
    Cells(1, 2) = "シート名"
    Cells(1, 3) = "変換後"
    Cells(1, 4) = "シート順"
    Cells(1, 5) = "ターゲットセル"
    Cells(1, 6) = "PDFフラグ"
    If pFlag Then
        Cells(1, 7) = "ページ数"
        Cells(1, 8) = "ﾍﾟｰｼﾞ計算"
        Cells(1, 9) = "先頭ﾍﾟｰｼﾞ"
    End If
    
    'シート名列の列幅を調整cWidthはグローバル定数
    Columns(2).ColumnWidth = cWidth
    Columns(3).ColumnWidth = cWidth
    
    'シート情報の書き出し
    Dim i  As Long, strSHname As String
    For i = 2 To Sheets.Count   'シートループ
        strSHname = Format(Sheets(i).Name, "@")
        
        Cells(i, 1) = i - 1     '��
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), _
                                    Address:="", _
                                    SubAddress:="'" & strSHname & "'!A1", _
                                    TextToDisplay:=strSHname  'シート名
        Cells(i, 3) = strSHname '変換後
        Cells(i, 4) = ""    'シート順
        Cells(i, 5) = Sheets(i).UsedRange.Address(0, 0) 'リンクターゲット
        Cells(i, 6) = 1 'PDF化フラグ
        If pFlag Then
            Cells(i, 7) = Sheets(i).PageSetup.Pages.Count   '
            Cells(i, 8).Formula = "=offset(" & Cells(i, 8).Address(0, 0) & ", -1 ,0 ) +offset(" & Cells(i, 8).Address(0, 0) & ", -1 ,-1 ) "
            Cells(i, 9) = Sheets(i).PageSetup.FirstPageNumber
        End If
    Next i
    
    'シート参照用数式を設定
    If pFlag = False Then
        Cells(1, 7) = "C3"  'シート共通の参照
        Cells(2, 7) = "=HYPERLINK(""#"" & $B2 & ""!""&G$1,INDIRECT(""'""&$B2&""'!""&G$1))"
    End If
    
    'パージ番号出力しない場合は、マクロボタン追加
    If addButtonFlag > 0 Then Call addMacroButton
    Application.ScreenUpdating = True
    
End Sub

'変換後 列の内容でシートを置換。空欄の場合は削除する。
Sub †シート名置換()
    Dim RC As Long
    If ActiveSheet.Name <> "†" Then Call errorEnd("シート管理シートを追加してください（左端必須）")
    If Cells(Rows.Count, 1).End(xlUp).Value + 1 <> Sheets.Count Then Call errorEnd("シート管理シートを更新してください")
    
    RC = MsgBox("シート名置換（名無しは削除）を実施します。事前保存しますか？？", vbYesNoCancel)
    If RC = vbYes Then
        Call 上書き保存してバックアップ
    ElseIf RC = vbCancel Then
        Exit Sub
    End If
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim i  As Long, tmp As String
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Value + 1
        If Cells(i, 3) = "" Then
            tmp = Cells(i, 2)
            Sheets(tmp).Delete
        Else
            tmp = Cells(i, 2)
            Sheets(tmp).Name = Cells(i, 3).text
        End If
    Next i
    
    Dim pFlag As Boolean
    If Sheets(1).Cells(1, "G") = "ページ数" Then pFlag = True
    
    'シート管理シートを更新
    Sheets(1).Delete
    Sheets.Add Before:=Sheets(1)
    ActiveSheet.Name = "†"
    Application.DisplayAlerts = True
    
    Call writeSheetList_main(pFlag)
    Application.ScreenUpdating = True
    
End Sub

'指定範囲の文字を連結
Private Function range2str(myRange As range) As String
    Dim r As range, tmp
    For Each r In myRange
        tmp = tmp & r.Value
    Next r
    range2str = tmp
End Function

'シートをシート順 列の順にソート
Sub †ソートブランク埋め()
    Sheets("†").Activate
    Dim eGyo As Long:    eGyo = Cells(Rows.Count, 1).End(xlUp).Row
    Dim cntRange As range:    Set cntRange = range("D2:D" & eGyo)
    If range2str(cntRange) = "" Then errorEnd ("レンジ「" & cntRange.Address(0, 0) & "」に番号を入力してください。")
    
    If WorksheetFunction.Max(cntRange) > eGyo - 1 Or WorksheetFunction.Min(cntRange) < 1 Then
        Call errorEnd("ソート順に0以下または" & eGyo - 1 & "より大きい数字があります")
    End If
    
    Dim i As Long, shft As Long
    For i = 1 To eGyo - 1
        If WorksheetFunction.CountIf(cntRange, i) = 0 Then
            Do While Cells(2, 4).Offset(shft, 0) <> ""
                shft = shft + 1
            Loop
            If Cells(2, 4).Offset(shft, 0).Row < eGyo + 1 Then
                Cells(2, 4).Offset(shft, 0) = i
            Else
                Call errorEnd("ソート順に半角数字以外があります")
            End If
        ElseIf WorksheetFunction.CountIf(cntRange, i) > 1 Then
            Call errorEnd("ソート順に重複があります=" & i)
        End If
    Next i
    With Sheets("†")   '並べ替え処理
        Dim tarGyo As Long, SHname As String
        Set cntRange = range("D1:D" & eGyo)
        For i = eGyo - 1 To 1 Step -1
            tarGyo = WorksheetFunction.Match(i, cntRange, 0)
            SHname = .Cells(tarGyo, 2)
            Sheets(SHname).Move Before:=Sheets(1)
        Next i
        .Move Before:=Sheets(1) '†シートを戻して完成
     End With
End Sub

'ハイパーリンクの対象セルをターゲット列の内容に更新
Sub †ターゲットセル更新()
    Dim i  As Long, tmp As String
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Value + 1
        If Cells(i, 5) <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:="", _
                SubAddress:="'" & Cells(i, 3) & "'!" & Cells(i, 5), TextToDisplay:=Sheets(i).Name
        End If
    Next i
End Sub

'全シートをPDF化する
Sub ◆PDF形式で全シート保存()
    Call †シート管理シートを追加
    Call †PDF形式で保存_フラグ
End Sub

'PDFフラグ列が０でないシートをPDF化
Sub †PDF形式で保存_フラグ()
    Sheets("†").Select
    Dim eGyo As Long:     eGyo = Cells(Rows.Count, 1).End(xlUp).Row
    Dim selectedSheets As Variant:    ReDim selectedSheets(1 To Sheets.Count)
    
    If WorksheetFunction.Sum(range("F2:F" & eGyo)) = 0 Then errorEnd ("PDFフラグをONにしてください。")
    If MsgBox("フラグONのシートをPDFに変換します。", vbOKCancel) = vbCancel Then End
    
    Dim sh As Long, Gyo As Long
    For Gyo = 2 To eGyo
        If Cells(Gyo, "F") > 0 Then
            sh = sh + 1
            selectedSheets(sh) = Cells(Gyo, "B").text
        End If
    Next Gyo
    
    Application.ScreenUpdating = False   'バックグラウンドで処理を始める
    
    ReDim Preserve selectedSheets(1 To sh)
    Sheets(selectedSheets).Select
     
     'PDFファイルで保存
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=getPDFfulname()

    '保存したPDFファイルを開く
    CreateObject("Shell.Application").ShellExecute getPDFfulname()
    
    Application.ScreenUpdating = True   'バックグラウンドで処理を終える
    Sheets("†").Activate
End Sub

'出力用PDFファイルのフルパスを返す
Function getPDFfulname()
    Dim aBookName As String: aBookName = ActiveWorkbook.Name
    Dim pPos As Integer: pPos = InStrRev(aBookName, ".") 'ピリオドの位置
    Dim baseName As String: baseName = Left(aBookName, pPos - 1)
    
    'ファイルのフルパスを作成して、結果を返す
    If ActiveWindow.selectedSheets.Count = 1 Then
       getPDFfulname = ActiveWorkbook.Path & "\" & baseName & "(" & ActiveSheet.Name & ").pdf"
    Else
       getPDFfulname = ActiveWorkbook.Path & "\" & baseName & ".pdf"
    End If
End Function

'シートの全オブジェクトを削除
Sub マクロボタン削除() 'Ctrl+F10でオブジェクトリスト
    Dim tobj As Shape
    For Each tobj In ActiveSheet.Shapes
         tobj.Delete        'オブジェクトを削除
    Next
End Sub

'マクロ用ボタンを追加
Sub addMacroButton()
    Dim rowOffset As Long: rowOffset = 3
    Dim tarRow As Long: tarRow = 2
    Call マクロボタン削除
    Call addMacroButton_main("オブジェクト削除", Cells(tarRow, "J"), "マクロボタン削除"): tarRow = tarRow + rowOffset
    Call addMacroButton_main("シート名置換", Cells(tarRow, "J"), "†シート名置換"): tarRow = tarRow + rowOffset
    Call addMacroButton_main("シートソート", Cells(tarRow, "J"), "†ソートブランク埋め"): tarRow = tarRow + rowOffset
    Call addMacroButton_main("リンクセル更新", Cells(tarRow, "J"), "†ターゲットセル更新"): tarRow = tarRow + rowOffset
    Call addMacroButton_main("PDF化", Cells(tarRow, "J"), "†PDF形式で保存_フラグ")
End Sub

'tarRangeの位置にtextを書いたオートシェープを作成し、macroNameのプロシージャを登録
Private Sub addMacroButton_main(text As String, tarRange As range, macroName As String)
    Const shiftBuf = 5
    With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, tarRange.Left + shiftBuf, tarRange.Top + shiftBuf, 1, 1.1)
       With .TextFrame
            .AutoSize = True    '自動調整のためサイズは１に設定
            .Characters.text = text '表示文字列
            .Characters.Font.Size = 10 '文字のサイズ
       End With
       .OnAction = ThisWorkbook.Name & "!" & macroName
    End With
End Sub

'異常メッセージを表示して終了
Private Sub errorEnd(msg As String)
    MsgBox msg
    End
End Sub

Private Sub 上書き保存してバックアップ()

    Dim バックアップ名 As String, ファイル名 As String, dEXT As String, pos As Long, BKUPpath As String, RC As Long, Savedate As Double
    BKUPpath = ActiveWorkbook.Path & "\BKUP"
       
    Dim Note As String
    Note = InputBox("ファイル名に記載する更新内容を入力してください。", "更新内容は？")
 
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(BKUPpath) Then
    Else '   "フォルダが存在しない場合は作る"
        FSO.CreateFolder BKUPpath
    End If
        
    ファイル名 = ActiveWorkbook.Name
    pos = InStrRev(ファイル名, ".") '後方検索でHIT位置を返す　前方はInStr 関数
    dEXT = Right(ファイル名, Len(ファイル名) - pos + 1) ' ピリオド付拡張子

    Savedate = FileDateTime(ActiveWorkbook.FullName)
    バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Savedate, "_yymmdd_hhmm") & "_BKUP" & dEXT
    FSO.CopyFile ActiveWorkbook.FullName, バックアップ名    '上書き保存後に
       
    ActiveWorkbook.Save
    
    If Note = "" Then
        バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Now, "_yymmdd_hhmm") & "_UPDT" & dEXT
    Else
        バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Now, "_yymmdd_hhmm") & "_UPDT(" & Note & ")" & dEXT
    End If
    FSO.CopyFile ActiveWorkbook.FullName, バックアップ名    '上書き保存後に
    
    Set FSO = Nothing
End Sub