趣味プログラミングblog

---

マクロの機能

元々の機能は、「シート名一覧を記載したハイパーリンクを出力する。」というもの。シート名を取得したいシーンはよくあるけど、標準機能にないから作った。

それだけの処理なら簡単だけど、使っているうちにカスタマイズが増えていき今の形に落ち着いた。

機能一覧

1. シート一覧を記載したシートを左端に挿入
2. 各機能を呼び出すボタンの挿入
3. 挿入したボタンの一括削除
4. シート名の一括置換
5. シートの選択削除
6. シートの並べ替え
7. 選択シートのPDF化
8. 各シートを参照する数式の挿入

機能がモリモリ過ぎて解説しきれないのが非常に残念。

個人的に気に入ってるのが最後に挙げた数式挿入。
シートがたくさんあるファイルって同じフォーマットってことが多い。
一行目でセルを指定すると各シートから指定セルの内容を表示することができる。



以下、ソース。テキストファイルは こちら。

---

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