趣味プログラミングblog

---

起点となるプロシージャは以下の２つ。
①†シート管理シートを追加()
②†シート管理シートを追加_ページ数付()

どちらも引数を設定してwriteSheetList_main()を呼ぶ。
可読性を上げるために、引数を直接設定せず定数に入れてから渡すようにした。

基本は①を使う。
②は手動でページ番号を入力してたクソみたいな伝統の名残。

①を実行すると図のように
†シートを追加して、シート一覧をリンク付でB列に書き込む。
セルをクリックすると、該当シートへジャンプ。戻るときは Alt + ←。

---

公開に合わせて、J列のマクロボタンを追加した。
「オブジェクト削除」を押すと、マクロボタン（オートシェープ）がすべて削除される。
ボタンが邪魔な時に使う。

「シート更新」を押すと、①の「†シート管理シートを追加」を再実行する。

「シート名置換」を押すと、B列のシートをC列の名前に置換する。
C列が空欄の場合は、シートを削除する。

「シートソート」を押すと、D列に振られた番号順にシートを並べ替える。
入力のない番号は、上から順に空欄を埋めるように入力するので、
数字が１つでも入っていれば並べ替え可能。マニアックだけどお気に入りの挙動。

「リンクセル更新」を押すと、リンク先のセルをA1からE列の内容に変更する。
各シートのUsedRangeをデフォルトとして入力した。

「PDF化」を押すと、F列に1が入力されたシートを選択し、
PDF化を行う。

---

●AddDuggerSheet()は、シート管理用に白紙の「†」シートを用意する。
すでにある場合は、確認のうえ消して作り直す。
確認メッセージの有無をフラグ管理して、共通部分を増やした。

シート一覧を出した後に特定のセルの文字を取り出す操作をよくやるので、
１セルだけ表示できるように数式を埋め込んだ。

G1セルに参照先のRange文字列が入っていて、
G1セルの位置を各シートから拾ってくる場合は、
G2セルの数式をG3セル以下コピーして使用する。

---

●addMacroButton()が、今回改良したマクロボタンを挿入するプロシージャ。
これまではPDF化のボタンのみであったが、汎用性をもたせるために
addMacroButton_mainを作成して一般化した。

マクロの登録って１行でできるのね。。。
ActiveSheet.Shapes.AddTextbox.OnAction =「ブック名」!「マクロ名」


前回とほぼ変わってないけど以下、ソース。ソースファイルはこちら。

---

Option Explicit
Const cWidth = 45
Const addButtonFlag = 1

Sub †シート管理シートを追加()
Const showMsgboxFlag = True
Call AddDuggerSheet(showMsgboxFlag)

Const addPageFlag = False
Call writeSheetList_main(addPageFlag)
End Sub

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

Const addPageFlag = True
Call writeSheetList_main(addPageFlag)
End Sub

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

'シート一覧を†シートに書き込み addPageFlagはページ情報を記載するフラグ
Private Sub writeSheetList_main(Optional addPageFlag 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 addPageFlag 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 addPageFlag 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 addPageFlag = 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 †シート名置換()
If ActiveSheet.Name <> "†" Then Call errorEnd("シート管理シートを追加してください（左端必須）")
If Cells(Rows.Count, 1).End(xlUp).value + 1 <> Sheets.Count Then Call errorEnd("シート管理シートを更新してください")

Dim RC As Long
RC = MsgBox("シート名置換（名無しは削除）を実施します。事前保存しますか？？", vbYesNoCancel)
If RC = vbYes Then
Call 上書き保存してバックアップ
ElseIf RC = vbCancel Then
End
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = 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

'シート管理シートを更新
Const showMsgboxFlag = False
Call AddDuggerSheet(showMsgboxFlag)

Dim addPageFlag As Boolean
If Sheets(1).Cells(1, "G") = "ページ数" Then addPageFlag = True
Call writeSheetList_main(addPageFlag)

Application.ScreenUpdating = True

End Sub


'シートをシート順 列の順にソート
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

'指定範囲の文字を連結
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 †ターゲットセル更新()
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 'sh：シートカウンタ
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("リンクセル更新", 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