発端
わかりみが深いです。
— W.D. (@WD4096) May 30, 2020
17年ちょっと前に作った補助機能群にも入れてました。
こんなの。リボンになってからショートカットで使うのがやりにくくなったので最近ほとんど使ってなかったのです。 pic.twitter.com/9hRU73OMvF
ばっちりさんのツイで、凄く昔に作った補助マクロ（VBA）の存在を思い出したのです。
で、折角だから公開してみようかと。
概要
下図にあるように、複数の機能をアドインするようになってます。
最初に作ったのは2000年前後で、機能をあれこれ足しながら使ってた記憶があるのですが、手元に残ってるのは2003年の日付になってました。
コード
凄く昔のコードなので結構汚いと思うのです。
「AddInとしてメニューに追加する」コード、「実際に動作するコード」、ユーザーフォームで動作するコード×２で構成されます。
しかも、ぬるいことに、当時はモジュール名を変更する癖がついてなかったようです。おぬるいですね。
Module1
Option Explicit
Public Const cst_cbarMainMenu = "EXCEL補助マクロ"
Public Const cst_cbarMacro1 = "先頭へ(&1)"
Public Const cst_cbarMacro2 = "最後尾へ(&2)"
Public Const cst_cbarMacro3 = "小文字へ(&3)"
Public Const cst_cbarMacro4 = "大文字へ(&4)"
Public Const cst_cbarMacro5 = "半角へ(&5)"
Public Const cst_cbarMacro6 = "全角へ(&6)"
Public Const cst_cbarMacro7 = "文字数(&7)"
Public Const cst_cbarMacro8 = "バイト数(&8)"
Public Const cst_cbarMacro9 = "重複チェック(&9)"
Public Const cst_cbarMacro0 = "シート削除(&0)"
Public Const cst_cbarMacroQ = "再採番(&Q)"
Public Const cst_cbarMacroS = "シート移動(&S)"
Public Const cst_cbarMacroU = "&UnInstall"
Public Const cst_cbarOnAction1 = "GoTop"
Public Const cst_cbarOnAction2 = "GoBottom"
Public Const cst_cbarOnAction3 = "ToLower"
Public Const cst_cbarOnAction4 = "ToUpper"
Public Const cst_cbarOnAction5 = "ToASC"
Public Const cst_cbarOnAction6 = "ToJIS"
Public Const cst_cbarOnAction7 = "DispLen"
Public Const cst_cbarOnAction8 = "DispLenB"
Public Const cst_cbarOnAction9 = "CheckDupe"
Public Const cst_cbarOnAction0 = "SheetDel"
Public Const cst_cbarOnActionQ = "ReNumber"
Public Const cst_cbarOnActionS = "SheetJump"
Public Const cst_cbarOnActionU = "ExcelAssist_AddinUninstall"
Sub GoTop()
Sheets(1).Activate
End Sub
Sub GoBottom()
'変数定義
Dim nSheets As Long
'--------------------------------------------------------------------------------
'シートの最後尾を取得
nSheets = Sheets.Count
'シートの最後尾に移動
Sheets(nSheets).Activate
End Sub
Sub ToLower()
'小文字へ変換
'--------------------------------------------------------------------------------
'変数定義
Dim sTemp As String
Dim oRange As Range
'--------------------------------------------------------------------------------
For Each oRange In Selection
sTemp = oRange.Text
sTemp = StrConv(sTemp, vbLowerCase)
oRange.Value = sTemp
Next
End Sub
Sub ToUpper()
'大文字へ変換
'--------------------------------------------------------------------------------
'変数定義
Dim sTemp As String
Dim oRange As Range
'--------------------------------------------------------------------------------
For Each oRange In Selection
sTemp = oRange.Text
sTemp = StrConv(sTemp, vbUpperCase)
oRange.Value = sTemp
Next
End Sub
Sub ToASC()
'半角へ変換
'--------------------------------------------------------------------------------
'変数定義
Dim sTemp As String
Dim oRange As Range
'--------------------------------------------------------------------------------
For Each oRange In Selection
sTemp = oRange.Text
sTemp = StrConv(sTemp, vbNarrow)
oRange.Value = sTemp
Next
End Sub
Sub ToJIS()
'全角へ変換
'--------------------------------------------------------------------------------
'変数定義
Dim sTemp As String
Dim oRange As Range
'--------------------------------------------------------------------------------
For Each oRange In Selection
sTemp = oRange.Text
sTemp = StrConv(sTemp, vbWide)
oRange.Value = sTemp
Next
End Sub
Sub DispLen()
'指定範囲の文字数合算を表示
'--------------------------------------------------------------------------------
'変数定義
Dim nLen As Long
Dim nSum As Long
Dim nMax As Long
Dim sTemp As String
Dim oRange As Range
'--------------------------------------------------------------------------------
nSum = 0
nMax = 0
For Each oRange In Selection
sTemp = oRange.Text
nLen = Len(sTemp)
If nLen > nMax Then
nMax = nLen
End If
nSum = nSum + nLen
Next
Call MyDisp("文字数合計＝" & CStr(nSum) & Chr(13) & "文字数最大＝" & CStr(nMax))
End Sub
Sub DispLenB()
'指定範囲の文字バイト数合算を表示
'--------------------------------------------------------------------------------
'変数定義
Dim nLen As Long
Dim nSum As Long
Dim nMax As Long
Dim sTemp As String
Dim oRange As Range
'--------------------------------------------------------------------------------
nSum = 0
nMax = 0
For Each oRange In Selection
sTemp = oRange.Text
nLen = LenB(sTemp)
If nLen > nMax Then
nMax = nLen
End If
nSum = nSum + nLen
Next
Call MyDisp("バイト数合計＝" & CStr(nSum) & Chr(13) & "バイト数最大＝" & CStr(nMax))
End Sub
Sub CheckDupe()
'重複チェック
'--------------------------------------------------------------------------------
'変数定義
Dim sTemp As String
Dim sTemp2 As String
Dim oRange As Range
Dim oRange2 As Range
Dim nCnt As Long
Dim sResult As String
Dim bFlag As Boolean
'--------------------------------------------------------------------------------
bFlag = False
sResult = ""
For Each oRange In Selection
sTemp = oRange.Text
'ブランク文字列の場合重複判定は省略
If sTemp <> "" Then
nCnt = 0
For Each oRange2 In Selection
sTemp2 = oRange2.Text
If sTemp = sTemp2 Then
nCnt = nCnt + 1
End If
Next
If nCnt > 1 Then
sResult = sResult & "、" & sTemp
bFlag = True
End If
End If
Next
If bFlag = True Then
Call MyDisp("重複文字列：" & Chr(13) & Mid(sResult, 2))
Else
Call MyDisp("重複文字列はありませんでした")
End If
End Sub
Sub SheetDel()
'現在のシートを削除する
ActiveSheet.Delete
End Sub
Sub ReNumber()
'--------------------------------------------------------------------------------
'再採番
'--------------------------------------------------------------------------------
'変数定義
Dim sTemp As String
Dim sChar As String
Dim sHeader As String
Dim sSEQ As String
Dim sFooter As String
Dim oRange As Range
Dim nCnt As Long
Dim nPos As Long
Dim bFlag As Boolean
'--------------------------------------------------------------------------------
bFlag = False
For Each oRange In Selection
sTemp = oRange.Text
If sTemp <> "" Then
If bFlag = True Then
nCnt = nCnt + 1
sTemp = sHeader & Trim(CStr(nCnt)) & sFooter
oRange.Value = sTemp
Else
nCnt = 0
sHeader = ""
sSEQ = ""
sFooter = ""
nPos = Len(sTemp)
'フッタ作成
Do Until nPos = 0
sChar = Mid(sTemp, nPos, 1)
If IsNumeric(sChar) = True Then
Exit Do
End If
sFooter = sChar & sFooter
nPos = nPos - 1
Loop
'連番初期値取得
Do Until nPos = 0
sChar = Mid(sTemp, nPos, 1)
If IsNumeric(sChar) = False Then
Exit Do
End If
sSEQ = sChar & sSEQ
nPos = nPos - 1
Loop
'連番が有効なら採番開始
If sSEQ <> "" Then
bFlag = True
nCnt = CLng(sSEQ)
'ヘッダ取得
If nPos > 0 Then
sHeader = Left(sTemp, nPos)
End If
End If
End If
End If
Next
End Sub
Sub SheetJump()
frmSheets.Show
End Sub
Private Sub MyDisp(strMessage As String)
'メッセージ表示
frmDisp.txtMessage.Text = strMessage
frmDisp.Show
frmDisp.Repaint
DoEvents
End Sub
'アドインメニューが存在するか確認
Public Function bExistThisAddinMenu(strMacro As String) As Boolean
On Error Resume Next
bExistThisAddinMenu = True
If Application.CommandBars(cst_cbarMainMenu).Controls.Count = 0 Then
bExistThisAddinMenu = False
' If Application.CommandBars(cst_cbarMainMenu).Controls(strMacro).Caption = "" Then
' '存在しない場合、RESUME NEXTにより下の文が実行される
' bExistThisAddinMenu = False
' End If
End If
End Function
'アドインのアンインストール
Sub ExcelAssist_AddinUninstall()
Dim ain As AddIn
'メニューバー消去
Application.CommandBars(cst_cbarMainMenu).Delete
For Each ain In Application.AddIns
If ain.Name = cst_cbarMainMenu & ".xla" Then
ain.Installed = False
Exit For
End If
Next ain
End Sub
Public Function InstallAddin(strPath As String)
'アドインインストール
'変数定義
Dim ain As AddIn
Dim bFlag As Boolean
Dim sAddin As String
'--------------------------------------------------------------------------------
'アドインへのパスを取得
sAddin = Left(strPath, Len(strPath) - 3) & "xla"
InstallAddin = sAddin
'アドインリストに乗っているかチェック
bFlag = False
For Each ain In Application.AddIns
If ain.Name = cst_cbarMainMenu & ".xla" Then
ain.Installed = True
bFlag = True
Exit For
End If
Next ain
'アドインリストに乗っていれば終了
If bFlag = True Then Exit Function
'アドインリストに新しく追加する
Application.AddIns.Add sAddin
For Each ain In Application.AddIns
If ain.Name = cst_cbarMainMenu & ".xla" Then
ain.Installed = True
Exit For
End If
Next ain
End Function
Public Function WhoAmI() As String
'変数定義
Dim ThisBook As String '現在のブック名称
'--------------------------------------------------------------------------------
'自分自身のブック名を取得する
ThisBook = Sheets(1).Application.ActiveWindow.Caption
'戻り値の設定
WhoAmI = ThisBook
End Function
Public Sub Auto_Remove()
End Sub
Sheel1
Option Explicit
Private Sub CommandButton1_Click()
'変数定義
Dim vRet As Variant
Dim sAddin As String
'--------------------------------------------------------------------------------
'アドインのインストール
sAddin = InstallAddin(Application.ThisWorkbook.Path & "\" & WhoAmI)
'メニューバーの追加
If bExistThisAddinMenu(cst_cbarMacro1) Then
vRet = MsgBox("すでにメニューは存在します。上書きしますか？", vbYesNo)
If vRet = vbYes Then
Call ExcelAssist_AddinUninstall
Else
Exit Sub
End If
End If
Call Application.CommandBars.Add(cst_cbarMainMenu, msoBarTop)
Application.CommandBars(cst_cbarMainMenu).Visible = True
With Application.CommandBars(cst_cbarMainMenu)
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro1
.OnAction = sAddin & "!" & cst_cbarOnAction1
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro2
.OnAction = sAddin & "!" & cst_cbarOnAction2
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro3
.OnAction = sAddin & "!" & cst_cbarOnAction3
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro4
.OnAction = sAddin & "!" & cst_cbarOnAction4
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro5
.OnAction = sAddin & "!" & cst_cbarOnAction5
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro6
.OnAction = sAddin & "!" & cst_cbarOnAction6
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro7
.OnAction = sAddin & "!" & cst_cbarOnAction7
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro8
.OnAction = sAddin & "!" & cst_cbarOnAction8
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro9
.OnAction = sAddin & "!" & cst_cbarOnAction9
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacro0
.OnAction = sAddin & "!" & cst_cbarOnAction0
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacroQ
.OnAction = sAddin & "!" & cst_cbarOnActionQ
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacroS
.OnAction = sAddin & "!" & cst_cbarOnActionS
End With
With .Controls.Add
.Style = msoButtonCaption
.Caption = cst_cbarMacroU
.OnAction = sAddin & "!" & cst_cbarOnActionU
End With
End With
'メニューバー表示
Application.AddIns(cst_cbarMainMenu).Installed = True
End Sub
frmDisp
Option Explicit
Private Sub cmdExit_Click()
Unload Me
End Sub
frmSelect
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub lstSheets_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ActiveWorkbook.Sheets(lstSheets.Text).Activate
Unload Me
End Sub
Private Sub lstSheets_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case vbKeyReturn
ActiveWorkbook.Sheets(lstSheets.Text).Activate
Unload Me
Case vbKeyEscape
Unload Me
End Select
End Sub
Private Sub UserForm_Initialize()
Dim objSheet As Object
For Each objSheet In ActiveWorkbook.Sheets
lstSheets.AddItem (objSheet.Name)
Next
lstSheets.ListIndex = 0
End Sub
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeyEscape Then
Unload Me
End If
End Sub
最後に
そういえば最近は全然使ってなかったりいじってなかったりします。
個人用マクロブック使ってる方も多いようですし、今更感はありますが、勤務先でも導入して流行らせてみましょうかね。
とか、考えてみたり。
