Excelマクロ とりあえず
はじめに
自分が結構、自社以外で作業することが多いのですが
・フリーソフトの使用禁止
・使用できるソフトが少ない
等で、結構戸惑うことが多く
せめてExcelだけでも自分の使いやすいものを集めた
ものを「ソースコード」で書いておけば
サイトからのコピベで、多少の時短になるのではと
考えて作成しました
エビデンスのときに
・赤枠がほしい
・吹き出しがほしい
・貼り付けた図形を黒縁を入れたい
等を主眼に作成しております
ざっくり画面説明
全体的にはこんな感じの構成になります
■Sheet1の画面イメージ
Sheet1に今回の各機能を設定する設定シートを作成しますが
ソース部分をせんぶコピべしたあと
マクロの「A_シート作成」を実行すると
Sheet1がこんな感じで設定シートとして咲く作成されます。
あとはE列に設定したい機能のキーを入れてください
Excelの仕様で
・アルファベットのみ
・大文字だと[Ctrl]+[Shift]+[E列の設定キー]
・小文字だと[Ctrl]+[E列の設定キー]
・Excelのショートカットキーとバッテングすると
まだ試したことがないので不明ですが
多分こちらが優位になるかと
・キーのアルファベットを変更後は「キー再設定」（この場合は[Ctrl]+[Shift]+[R]）で
設定が反映されます。
ソース部分
■Sheet1
Sheet1
Option Explicit
'--------------------------
'マクロキーの設定
'--------------------------
Public Sub SubMacroSet()
Dim intRowCnt As Integer
Dim intSelNo As Integer
intSelNo = 1
For intRowCnt = SetStartRow To SetEndRow
If Trim(Cells(intRowCnt, Sel_FunctionName).Value) <> "" Then
'連番
Cells(intRowCnt, Sel_SetNo).Value = intSelNo
intSelNo = intSelNo + 1
'マクロキー設定
Application.MacroOptions Macro:=Cells(intRowCnt, Sel_ModuleName).Value & "." & Cells(intRowCnt, Sel_FunctionName).Value, ShortcutKey:=Cells(intRowCnt, Sel_Set_Key).Value
'大文字小文字判定
If Cells(intRowCnt, Sel_Set_Key).Value = UCase(Cells(intRowCnt, Sel_Set_Key).Value) Then
'大文字
Cells(intRowCnt, Sel_ShortCutKey).Value = "[" & Cells(intRowCnt, Sel_Set_Key).Value & "]+" & Sel_SET_KEY_Ctrl_Sift
Else
'小文字
Cells(intRowCnt, Sel_ShortCutKey).Value = "[" & UCase(Cells(intRowCnt, Sel_Set_Key).Value) & "]+" & Sel_SET_KEY_Ctrl
End If
If Trim(Cells(intRowCnt, Sel_Set_Key).Value) = "" Then
'設定なし
Cells(intRowCnt, Sel_ShortCutKey).Value = ""
End If
Else
End If
Next intRowCnt
End Sub
■ThisWorkbook
ThisWorkbook
Private Sub Workbook_Open()
Sheet1.Select
G_FontCoror = 1
G_CellCoror = 0
G_CellGetCoror = -1
G_ClipNo = 1
G_ClipSet = 1
Call Sheet1.SubMacroSet
End Sub
モジュール定義
■my_CellEeit
my_CellEeit
Option Explicit
'*******************************************
'** 選択したセルの色を取得
'*******************************************
Public Sub subGetSelColor()
With Selection.Interior
G_CellGetCoror = .Color
End With
MsgBox "セルの色を取得しました[" & G_CellGetCoror & "]"
'クリップボードに色をコピー
With New MSForms.DataObject
.SetText G_CellGetCoror '変数の値をDataObjectに格納する
.PutInClipboard 'DataObjectのデータをクリップボードに格納する
End With
End Sub
'*******************************************
'** セルの色指定
'*******************************************
Public Sub subCellCoror()
Dim strCoror As String
Dim intCoror As Integer
strCoror = InputBox("[文字色] ０:透明 ９９：取得したセル色" & vbCrLf & _
"１:黒 ２:赤 ３:黄 ４:青 ５:緑" & vbCrLf & _
"６:薄緑 ７:水色 ８:紫 ９:灰色 ", _
"セル色指定", G_CellCoror)
'指定がない場合
If Trim(strCoror) = "" Then
Exit Sub
End If
'全角文字の場合は半角文字に変換
intCoror = Trim(StrConv(strCoror, vbNarrow))
With Selection.Interior
If intCoror = 0 Then
'0:透明
.Pattern = xlNone
ElseIf intCoror = 99 Then
'99:取得したセル色
.Color = G_CellGetCoror
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
Else
.Color = My_Common.fncGetColor(intCoror)
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End If
.TintAndShade = 0
.PatternTintAndShade = 0
End With
G_CellCoror = intCoror
End Sub
'*******************************************
'** ソース用の枠を作成
'*******************************************
Public Sub subCodeFrame()
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 13434879
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
'*******************************************
'** 枠線作成
'*******************************************
Public Sub SubMakeFrameLine()
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
'*******************************************
'** 枠線解除
'*******************************************
Public Sub SubRemoveFrame()
With Selection.Font
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
■my_ClipBoard
my_ClipBoard
Option Explicit
'**********************************************
'** クリップボード操作関連
'**********************************************
'=============================================================
'*必要設定
'「Microsoft Forms 2.0 Object Library」を参照設定
'すること（ツール→参照設定）
'ない場合
'「C:\Windows\System32\FM20.DLL」
'「C:\Windows\SysWOW64\FM20.DLL」
'=============================================================
'**********************************************
'** クリップボードメニュー
'**********************************************
Public Sub subClipMenu()
Dim strSetNo As String
Dim intSetNo As Integer
strSetNo = InputBox("[コピー内容]" & vbCrLf & _
"１:日付線 " & vbCrLf & _
"２:日付(YYYYMMDD) " & vbCrLf & _
"３:日時(YYYYMMDD_HHMMDD) " & vbCrLf & _
"４:作業(YYYY年MM月DD日作業) " & vbCrLf & _
" ", _
"定型文", G_ClipNo)
'全角文字の場合は半角文字に変換
intSetNo = Trim(StrConv(strSetNo, vbNarrow))
'指定がない場合
If Trim(strSetNo) = "" Then
Exit Sub
End If
Select Case intSetNo
Case 1
Call setClipDayLine
G_ClipNo = intSetNo
Case 2
Call setClipDay
G_ClipNo = intSetNo
Case 3
Call setClipDayTime
G_ClipNo = intSetNo
Case 4
Call setClipDayJog
Case Else
Call sebSetClipBoard("")
End Select
End Sub
'**********************************************
'** 日付ライン(クリップボード)
'**********************************************
Private Sub setClipDayLine()
Dim wStrDate As String
wStrDate = Format(Now(), "yyyy年mm月dd日 Hh:nn:ss")
sebSetClipBoard ("-----------------------【" & wStrDate & "】----------------------------------" & vbCrLf & "【】" & vbCrLf & vbCrLf)
End Sub
'**********************************************
'** 日時(YYYYMMDD)(クリップボード)
'**********************************************
Private Sub setClipDay()
Dim wStrDate As String
wStrDate = Format(Now(), "yyyymmdd")
sebSetClipBoard (wStrDate)
End Sub
'**********************************************
'** 日時(YYYYMMDD_HHMMDD)(クリップボード)
'**********************************************
Private Sub setClipDayTime()
Dim wStrDate As String
wStrDate = Format(Now(), "yyyymmdd_Hhnnss")
sebSetClipBoard (wStrDate)
End Sub
'**********************************************
'** 日時(YYYY年MM月DD日作業)(クリップボード)
'**********************************************
Private Sub setClipDayJog()
Dim wStrDate As String
wStrDate = Format(Now(), "yyyy年mm月dd日作業")
sebSetClipBoard (wStrDate)
End Sub
'**********************************************
'** クリップボードに書き込む
'**********************************************
Private Sub sebSetClipBoard(pbuf As String)
With New MSForms.DataObject
.SetText pbuf '変数の値をDataObjectに格納する
.PutInClipboard 'DataObjectのデータをクリップボードに格納する
End With
End Sub
■My_Common
My_Common
Option Explicit
'*******************************************
'** 色を設定する
'*******************************************
Public Function fncGetColor(ByRef pColrNo As Integer) As Long
Dim strCoror As String
Dim lngCoror As Long
fncGetColor = vbBlack
'全角文字の場合は半角文字に変換
Select Case pColrNo
Case 0
'0:透明（セルのみ）
lngCoror = 0
Case 1
'1:黒
lngCoror = vbBlack
Case 2
'2:赤
lngCoror = vbRed
Case 3
'3:黄
lngCoror = vbYellow
Case 4
'4:青
lngCoror = vbBlue
Case 5
'5:緑
lngCoror = vbGreen
Case 6
'6:薄緑
lngCoror = 5296274
Case 7
'7:水色
lngCoror = vbCyan
Case 8
'8:紫
lngCoror = 10498160
Case 9
'8:灰色
lngCoror = 12632256
Case Else
'それ以外
'0:透明（セルのみ）
lngCoror = 0
End Select
fncGetColor = lngCoror
End Function
■My_Const
My_Const
Option Explicit
Public G_ClipNo As Integer
Public G_FontCoror As Integer
Public G_CellCoror As Integer
Public G_ClipSet As Integer
Public G_CellGetCoror As Long
Public G_BeforeInputKeyNo As Integer
Public G_BeforeInputName As String
'読込行数設定
Public Const SetStartRow As Integer = 4 '読込開始行
Public Const SetEndRow As Integer = 30 '読込終了行
'各項目設定
Public Const Sel_SetNo = 1 '連番
Public Const Sel_MacroGrp = 2 'マクログループ
Public Const Sel_MacroName As Integer = 3 ' マクロ名称
Public Const Sel_ShortCutKey As Integer = 4 ' ショートカットキー
Public Const Sel_Set_Key As Integer = 5 ' 設定キー
Public Const Sel_ModuleName As Integer = 6 ' マクロが入っているモジュール名
Public Const Sel_FunctionName As Integer = 7 ' マクロ関数名
Public Const Sel_SET_KEY_Ctrl_Sift As String = "Ctrl+Shift" ' キー [Ctrl][Shift]
Public Const Sel_SET_KEY_Ctrl As String = "Ctrl" ' キー [Ctrl]
■My_Font
My_Font
Option Explicit
'*******************************************
'** 文字色設定する
'*******************************************
Public Sub subFontColor()
Dim strCoror As String
Dim intCororNo As Integer
strCoror = ""
strCoror = InputBox("[文字色]" & vbCrLf & _
"１:黒 ２:赤 ３:黄 ４:青 ５:緑" & vbCrLf & _
"６:薄緑 ７:水色 ８:紫 ９:灰色", _
"文字色", G_FontCoror)
'指定がない場合
If Trim(strCoror) = "" Then
Exit Sub
End If
'全角文字の場合は半角文字に変換
intCororNo = Trim(StrConv(strCoror, vbNarrow))
With Selection.Font
If intCororNo = 0 Then
'0:透明
Else
.Color = My_Common.fncGetColor(intCororNo)
End If
.TintAndShade = 0
End With
G_FontCoror = intCororNo
End Sub
'*******************************************
'** 取り消し線
'*******************************************
Public Sub subCanselLine()
With Selection.Font
If .Strikethrough = True Then
.Strikethrough = False '水平取消線:無し
.Superscript = False '上付き文字:無し
.Subscript = False '下付き文字:無し
.Underline = xlUnderlineStyleNone '下線(xlUnderlineStyleNone:なし)
Else
.Strikethrough = True '水平取消線:あり
.Superscript = False '上付き文字
.Subscript = False '下付き文字
.Underline = xlUnderlineStyleNone '下線(xlUnderlineStyleNone:なし)
.Color = vbRed 'フォントの色：赤色
End If
End With
End Sub
'*******************************************
'** フォント：ＭＳ Ｐゴシック サイズ１１設定
'*******************************************
Public Sub Font_Set_MSP11()
With Selection.Font
.Name = "ＭＳ Ｐゴシック" 'フォント名：ＭＳ Ｐゴシック
.Size = 11 'フォントのサイズ：11P
.Strikethrough = False '水平取消線:無し
.Superscript = False '上付き文字:無し
.Subscript = False '下付き文字:無し
.OutlineFont = False 'アウトライン フォント:無し
.Shadow = False '影付きフォント:無し
.Underline = xlUnderlineStyleNone '下線(xlUnderlineStyleNone:なし)
.ColorIndex = 1 'フォントの色(2003までの56色カラーパレットのインデックス)
.TintAndShade = 0 '色を明るく、または暗く(2007以降)
.ThemeFont = xlThemeFontNone 'テーマのフォント(2007以降)
End With
End Sub
'*******************************************
'** フォント：ＭＳ Ｐゴシック サイズ１１設定(フォントの色の設定はなし)
'*******************************************
Public Sub Font_Set_MSP11_NonColor()
With Selection.Font
.Name = "ＭＳ Ｐゴシック" 'フォント名：ＭＳ Ｐゴシック
.Size = 11 'フォントのサイズ：11P
.Strikethrough = False '水平取消線:無し
.Superscript = False '上付き文字:無し
.Subscript = False '下付き文字:無し
.OutlineFont = False 'アウトライン フォント:無し
.Shadow = False '影付きフォント:無し
.Underline = xlUnderlineStyleNone '下線(xlUnderlineStyleNone:なし)
End With
End Sub
■My_SheetEdit
My_SheetEdit
Option Explicit
Private P_iSheetCnt As Integer
Private P_iKeyCnt As Integer
'--------------------------
'シートのセルを書き込む
'--------------------------
Public Sub A_シート作成()
P_iSheetCnt = 0
P_iKeyCnt = 0
' 1 番目のシートを設定
'---------------------------------------------------------
Call lineSelSet("H", "", "機能", "", "設定", "", "", CLng(65535))
Call lineSelSet("H", "", "マクロ", "ショートカットキー", "設定Key", "モジュール名", "関数名", CLng(65535))
'---------------------------------------------------------
Call lineSelSet("D", "設定", "キー再設定", "[R]+Ctr+Sift", "R", "Sheet1", "SubMacroSet", CLng(16777215))
'---------------------------------------------------------
Call lineSelSet("D", "図形", " 黄色吹き出し挿入", "[T]+Ctr+Sift", "T", "MyMacro", "subInsYellowBaloon", CLng(15917529))
Call lineSelSet("D", "", "赤枠(角丸)挿入", "[Y]+Ctr+Sift", "Y", "MyMacro", "subInsRedCircleFrame", CLng(15917529))
Call lineSelSet("D", "", "矢印(青色)挿入", " [D]+Ctrl+Shif", "D", "MyMacro", "subInsDownArrow", CLng(15917529))
'---------------------------------------------------------
Call lineSelSet("D", "図形(選択)", "図形に黒枠を入れる", "[I]+Ctr+Sift", "I", "MyMacro", "subFigureLine", CLng(14348258))
Call lineSelSet("D", "", "選択図形を最前面にする", "[J]+Ctrl+Shift", "J", "MyMacro", "subFigureFront", CLng(14348258))
Call lineSelSet("D", "", "選択図形を最背面にする", "[J]+Ctrl", "j", "MyMacro", "subFigureBack", CLng(14348258))
'---------------------------------------------------------
Call lineSelSet("D", "セル関連", "セルの色の設定", "[E]+Ctr+Sift", "E", "my_CellEeit", "subCellCoror", CLng(10086143))
Call lineSelSet("D", "", "選択したセルの色を取得", "[Q]+Ctr+Sift", "Q", "my_CellEeit", "subGetSelColor", CLng(10086143))
Call lineSelSet("D", "", "枠線作成", "[M]+Ctr", "m", "my_CellEeit", "SubMakeFrameLine", CLng(10086143))
Call lineSelSet("D", "", "枠線解除", "[M]+Ctr+Sift", "M", "my_CellEeit", "SubRemoveFrame", CLng(10086143))
Call lineSelSet("D", "", "ソース用の枠を作成", "[U]+Ctr+Sift", "U", "my_CellEeit", "subCodeFrame", CLng(10086143))
Call lineSelSet("D", "", "書式設定", "", "", "MyMacro", "subFormatset", CLng(10086143))
Call lineSelSet("D", "", "すべてのシートをA1設定にする", "[S]+Ctr+Sift", "S", "MyMacro", "subAllSheetTop", CLng(10086143))
'---------------------------------------------------------
Call lineSelSet("D", "文字関連", "文字色の設定", "[F]+Ctr+Sift", "F", "My_Font", "subFontColor", CLng(14083324))
Call lineSelSet("D", "", "取り消し線", "[D]+Ctr", "d", "My_Font", "subCanselLine", CLng(14083324))
Call lineSelSet("D", "", "フォントサイズ統一(MS Pゴシック 11)", "", "", "My_Font", "Font_Set_MSP11", CLng(14083324))
Call lineSelSet("D", "", "フォントサイズ統一(MS Pゴシック 11)(色変無し)", "[B]+Ctr+Sift", "B", "My_Font", "Font_Set_MSP11_NonColor", CLng(14083324))
'---------------------------------------------------------
Call lineSelSet("D", "リスト", "クリップボード", "[C]+Ctrl+Shift", "C", "my_ClipBoard", "subClipMenu", CLng(11854022))
Call lineSelSet("D", "", "リスト一覧", "[L]+Ctr+Sift", "L", "My_SheetEdit", "SubMacroList", CLng(11854022))
P_iSheetCnt = P_iSheetCnt + 3
Sheet1.Range("C" & (P_iSheetCnt)).Value = "※設定KEY アルファベットのみ "
Sheet1.Range("C" & (P_iSheetCnt + 1)).Value = "大文字：Ctrl+Shift"
Sheet1.Range("C" & (P_iSheetCnt + 2)).Value = "小文字：Ctrl"
'セル幅を自動設定
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
'--------------------------
'シート作成（行毎に設定する）
'--------------------------
Private Sub lineSelSet(sKBN As String, _
sBsel As String, _
sCsel As String, _
sDsel As String, _
sEsel As String, _
sFsel As String, _
sGsel As String, _
lngColor As Long)
Dim sAsel As String
sAsel = ""
P_iSheetCnt = P_iSheetCnt + 1
If sKBN = "D" Then
P_iKeyCnt = P_iKeyCnt + 1
sAsel = CStr(P_iKeyCnt)
Else
sAsel = ""
End If
Dim setRange As Range
'番号(背景黄色固定)
Set setRange = Sheet1.Range("A" & P_iSheetCnt)
Call subCodeFrame(setRange, CLng(65535), sAsel)
'マクロのジャンル
Set setRange = Sheet1.Range("B" & P_iSheetCnt)
Call subCodeFrame(setRange, lngColor, sBsel)
'マクロの内容
Set setRange = Sheet1.Range("C" & P_iSheetCnt)
Call subCodeFrame(setRange, lngColor, sCsel)
'ショートカットキー
Set setRange = Sheet1.Range("D" & P_iSheetCnt)
Call subCodeFrame(setRange, lngColor, sDsel)
'設定Key
Set setRange = Sheet1.Range("E" & P_iSheetCnt)
Call subCodeFrame(setRange, lngColor, sEsel)
'モジュール名
Set setRange = Sheet1.Range("F" & P_iSheetCnt)
Call subCodeFrame(setRange, lngColor, sFsel)
'関数名
Set setRange = Sheet1.Range("G" & P_iSheetCnt)
Call subCodeFrame(setRange, lngColor, sGsel)
Set setRange = Nothing
End Sub
'------------------------------------------------
'各設定セルごとの罫線・背景色・値設定
'------------------------------------------------
Private Sub subCodeFrame(oRange As Range, lngColor As Long, strVal As String)
With oRange
'値設定
.Value = strVal
'罫線設定
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
'背景色設定
.Interior.Color = lngColor
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
End With
End Sub
'--------------------------
'設定シートをリセットする
'--------------------------
Sub 設定シートリセット()
'Sheets(1).Select ' 1 番目のシートを選択
Sheets.Cells.Select 'すべて選択
'シートリセット
Sheet1.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Sheet1.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Sheet1.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Sheet1.Selection.Borders(xlEdgeTop).LineStyle = xlNone
Sheet1.Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Sheet1.Selection.Borders(xlEdgeRight).LineStyle = xlNone
Sheet1.Selection.Borders(xlInsideVertical).LineStyle = xlNone
Sheet1.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Sheet1.Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Sheet1.Selection.ClearContents
End Sub
'--------------------------
'ショートカットキー一覧
'--------------------------
Public Sub SubMacroList()
Dim intRowCnt As Integer
Dim intSelNo As Integer
Dim strMsg As String
strMsg = ""
intSelNo = 1
For intRowCnt = SetStartRow To SetEndRow
If Trim(Sheet1.Cells(intRowCnt, Sel_MacroGrp).Value) <> "" And strMsg <> "" Then
strMsg = strMsg & "--------------------" & vbCrLf
End If
If Trim(Sheet1.Cells(intRowCnt, Sel_FunctionName).Value) <> "" And Trim(Sheet1.Cells(intRowCnt, Sel_Set_Key).Value) <> "" Then
strMsg = strMsg & Sheet1.Cells(intRowCnt, Sel_ShortCutKey).Value & "：" & Sheet1.Cells(intRowCnt, Sel_MacroName).Value & vbCrLf
End If
Next intRowCnt
Call MsgBox(strMsg, vbOKOnly, "キー設定")
End Sub
'--------------------------
'ショートカットキー一覧(入力も可能)
'--------------------------
Public Sub SubMacroListBox()
Dim intRowCnt As Integer
Dim intSelNo As Integer
Dim strMsg As String
Dim retKeyNo As String
strMsg = ""
intSelNo = 1
If G_BeforeInputKeyNo > 0 Then
strMsg = "[00]前回の動作 : " & G_BeforeInputName & vbCrLf
End If
For intRowCnt = SetStartRow To SetEndRow
If Trim(Sheet1.Cells(intRowCnt, Sel_MacroGrp).Value) <> "" And strMsg <> "" Then
strMsg = strMsg & "--------------------" & vbCrLf
End If
If Trim(Sheet1.Cells(intRowCnt, Sel_FunctionName).Value) <> "" Then
strMsg = strMsg & "[" & Sheet1.Cells(intRowCnt, Sel_SetNo).Value & "]" & "：" & _
Sheet1.Cells(intRowCnt, Sel_MacroName).Value & vbCrLf
End If
Next intRowCnt
retKeyNo = InputBox(strMsg, "処理選択")
For intRowCnt = SetStartRow To SetEndRow
If Trim(Sheet1.Cells(intRowCnt, Sel_SetNo).Value) = retKeyNo Then
G_BeforeInputKeyNo = Sheet1.Cells(intRowCnt, Sel_SetNo).Value
G_BeforeInputName = Sheet1.Cells(intRowCnt, Sel_MacroName).Value
Exit For
End If
Next intRowCnt
End Sub
■MyMacro
MyMacro
Option Explicit
'*******************************************
'** 黄色吹き出し挿入
'*******************************************
Public Sub subInsYellowBaloon()
With Selection
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, Left:=.Left, Top:=.Top, Width:=70, Height:=30).Select
End With
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.TextFrame2.TextRange.Font
.UnderlineStyle = msoNoUnderline
.Italic = msoFalse
.Bold = msoFalse
.Fill.ForeColor.RGB = RGB(0, 0, 0)
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Weight = 0.75
End With
End Sub
'*******************************************
'** 赤枠(角丸)挿入
'*******************************************
Public Sub subInsRedCircleFrame()
With Selection
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Left:=.Left, Top:=.Top, Width:=50, Height:=15).Select
End With
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Weight = 2.25
End With
End Sub
'*******************************************
'** 矢印挿入
'*******************************************
Sub subInsDownArrow()
With Selection
ActiveSheet.Shapes.AddShape(msoShapeDownArrow, Left:=.Left, Top:=.Top, Width:=53, Height:=72).Select
End With
End Sub
'*******************************************
'** 絶対値変換(未完成)
'*******************************************
Public Sub SubChgAbsoluteValue()
With Selection
If selectCell.HasFormula Then '選択範囲の中の処理するセルが入力されているならば次の処理を行う
selectCell.Formula = Application.ConvertFormula(Formula:=selectCell.Formula, _
fromReferenceStyle:=xlA1, toAbsolute:=xlAbsolute) '参照部分を絶対参照に変更する処理
End If
End With
End Sub
'*******************************************
'** 書式一括設定
'*******************************************
Public Sub subFormatset()
Dim strFormat As String
Dim intCnt As Integer
Dim lngColor As Long
'全選択
Cells.Select
For intCnt = 1 To 9
Select Case intCnt
Case 1
strFormat = "=FIND(""Private Sub"",TRIM(A1)) = 1"
lngColor = vbBlue
Case 2
strFormat = "=FIND(""Private Sub"",TRIM(A1)) = 1"
lngColor = vbBlue
Case 3
strFormat = "=FIND(""End Sub"",TRIM(A1)) = 1"
lngColor = vbBlue
Case 4
strFormat = "=FIND(""Private Function"",TRIM(A1)) = 1"
lngColor = vbBlue
Case 6
strFormat = "=FIND(""Public Function"",TRIM(A1)) = 1"
lngColor = vbBlue
Case 5
strFormat = "=FIND(""End Function"",TRIM(A1)) = 1"
lngColor = vbBlue
Case 7
strFormat = "=FIND(""'"",TRIM(A1)) = 1"
lngColor = 5296274
Case 8
strFormat = "=FIND(""--"",TRIM(A1)) = 1"
lngColor = 5296274
Case 9
strFormat = "=FIND(""REM"",TRIM(A1)) = 1"
lngColor = 5296274
End Select
'書式設定
Selection.FormatConditions.Add Type:=xlExpression, Formula1:=strFormat
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = lngColor
End With
Selection.FormatConditions(1).StopIfTrue = False
Application.CutCopyMode = False
Next
'全選択解除
Range("A1").Select
End Sub
'*******************************************
' 図形を黒枠で囲む
'*******************************************
Sub subFigureLine()
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorDark1
End With
End Sub
'*******************************************
' 80%縮小を黒枠で囲む
'*******************************************
Sub subSyukusyouLine()
'50%縮小
With Selection
.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
End With
'黒枠
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorDark1
End With
End Sub
'*******************************************
' 図形を最前面にする
'*******************************************
Sub subFigureFront()
Selection.ShapeRange.ZOrder msoBringToFront
End Sub
'*******************************************
' 図形を最背面にする
'*******************************************
Sub subFigureBack()
Selection.ShapeRange.ZOrder msoSendToBack
End Sub
'**********************************************
'** すべてのシートをA1にして最初のシートにする
'**********************************************
Sub subAllSheetTop()
Dim WB As Workbook
Set WB = ActiveWorkbook
Dim WS As Worksheet
For Each WS In WB.Worksheets
WS.Activate
WS.Range("A1").Select
Next
WB.Worksheets(1).Activate
End Sub
'**********************************************
'** 目次のページに移動する
'**********************************************
Sub sub_GotoFirstSheet()
SheetFirst.Select
SheetFirst.Range("B2").Select
End Sub