LoginSignup
0
2

More than 1 year has passed since last update.

@inokou

【ツール】Excel小技便利マクロツール

Last updated at Posted at 2020-06-15

Excelマクロ　とりあえず

はじめに

自分が結構、自社以外で作業することが多いのですが
・フリーソフトの使用禁止
・使用できるソフトが少ない
等で、結構戸惑うことが多く

せめてExcelだけでも自分の使いやすいものを集めた
ものを「ソースコード」で書いておけば
サイトからのコピベで、多少の時短になるのではと
考えて作成しました

エビデンスのときに
・赤枠がほしい
・吹き出しがほしい
・貼り付けた図形を黒縁を入れたい
等を主眼に作成しております

シート定義

■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()

    G_FontCoror = 1
    G_CellCoror = 0
    G_CellGetCoror = -1
    G_ClipNo = 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
'*******************************************
' 80%縮小を黒枠で囲む
'*******************************************
Sub subSyukusyouLine()
    '80%縮小
    With Selection
        .ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
    End With
    
    '黒枠
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorDark1
    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 & _
                        "　", _
                        "定型文", 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 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

'**********************************************
'** クリップボードに書き込む
'**********************************************
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_CellGetCoror As Long

'読込行数設定
Public Const SetStartRow As Integer = 3         '読込開始行
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

'--------------------------
'シートのセルを書き込む
'--------------------------
Public Sub シート作成()

 
    ' 1 番目のシートを設定

    '---------------------------------------------------------
    Call lineSelSet(1, "", "", "機能", "", "設定", "", "", CLng(65535))
    Call lineSelSet(2, "", "", "マクロ", "ショートカットキー", "設定Key", "モジュール名", "関数名", CLng(65535))
    '---------------------------------------------------------
    Call lineSelSet(3, "1", "設定", "キー再設定", "[R]+Ctr+Sift", "R", "Sheet1", "SubMacroSet", CLng(16777215))
    '---------------------------------------------------------
    Call lineSelSet(4, "2", "図形", " 黄色吹き出し挿入", "[T]+Ctr+Sift", "T", "MyMacro", "subInsYellowBaloon", CLng(15917529))
    Call lineSelSet(5, "3", "", "赤枠(角丸)挿入", "[Y]+Ctr+Sift", "Y", "MyMacro", "subInsRedCircleFrame", CLng(15917529))
    '---------------------------------------------------------
    Call lineSelSet(6, "4", "図形(選択)", "図形に黒枠を入れる", "[I]+Ctr+Sift", "I", "MyMacro", "subFigureLine", CLng(14348258))
    Call lineSelSet(7, "5", "", "選択図形を最前面にする", "[J]+Ctrl+Shift", "J", "MyMacro", "subFigureFront", CLng(14348258))
    Call lineSelSet(8, "6", "", "選択図形を最背面にする", "[J]+Ctrl", "j", "MyMacro", "subFigureBack", CLng(14348258))
    Call lineSelSet(9, "7", "", "80%縮小を黒枠で囲む", "[E]+Ctr+Sift", "E", "MyMacro", "subSyukusyouLine", CLng(14348258))
    '---------------------------------------------------------
    Call lineSelSet(10, "8", "セル関連", "セルの色の設定", "[E]+Ctr+Sift", "E", "my_CellEeit", "subCellCoror", CLng(10086143))
    Call lineSelSet(11, "9", "", "選択したセルの色を取得", "[Q]+Ctr+Sift", "Q", "my_CellEeit", "subGetSelColor", CLng(10086143))
    Call lineSelSet(12, "10", "", "枠線作成", "[M]+Ctr", "m", "my_CellEeit", "SubMakeFrameLine", CLng(10086143))
    Call lineSelSet(13, "11", "", "枠線解除", "[M]+Ctr+Sift", "M", "my_CellEeit", "SubRemoveFrame", CLng(10086143))
    Call lineSelSet(14, "12", "", "ソース用の枠を作成", "[U]+Ctr+Sift", "U", "my_CellEeit", "subCodeFrame", CLng(10086143))
    Call lineSelSet(15, "13", "", "書式設定", "", "", "MyMacro", "subFormatset", CLng(10086143))
    Call lineSelSet(16, "14", "", "すべてのシートをA1設定にする", "[S]+Ctr+Sift", "S", "MyMacro", "subAllSheetTop", CLng(10086143))
    '---------------------------------------------------------
    Call lineSelSet(17, "15", "文字関連", "文字色の設定", "[F]+Ctr+Sift", "F", "My_Font", "subFontColor", CLng(14083324))
    Call lineSelSet(18, "16", "", "取り消し線", "[D]+Ctr", "d", "My_Font", "subCanselLine", CLng(14083324))
    Call lineSelSet(29, "17", "", "フォントサイズ統一(MS Pゴシック 11)", "", "", "My_Font", "Font_Set_MSP11", CLng(14083324))
    Call lineSelSet(20, "18", "", "フォントサイズ統一(MS Pゴシック 11)(色変無し)", "[B]+Ctr+Sift", "B", "My_Font", "Font_Set_MSP11_NonColor", CLng(14083324))
    '---------------------------------------------------------
    Call lineSelSet(21, "19", "リスト", "クリップボード", "[C]+Ctrl+Shift", "C", "my_ClipBoard", "subClipMenu", CLng(11854022))
    Call lineSelSet(22, "20", "", "リスト一覧", "[L]+Ctr+Sift", "L", "My_SheetEdit", "SubMacroList", CLng(11854022))

    Sheet1.Range("C25").Value = "※設定KEY　アルファベットのみ "
    Sheet1.Range("C26").Value = "大文字：Ctrl+Shift"
    Sheet1.Range("C27").Value = "小文字：Ctrl"

    'セル幅を自動設定
    Cells.Select
    Cells.EntireColumn.AutoFit

End Sub
'--------------------------
'シート作成（行毎に設定する）
'--------------------------
Private Sub lineSelSet(iLine As Integer, _
                       sAsel As String, _
                       sBsel As String, _
                       sCsel As String, _
                       sDsel As String, _
                       sEsel As String, _
                       sFsel As String, _
                       sGsel As String, _
                       lngColor As Long)
    
    Dim setRange As Range
    '番号(背景黄色固定)
    Set setRange = Sheet1.Range("A" & iLine)
    Call subCodeFrame(setRange, CLng(65535), sAsel)

    'マクロのジャンル
    Set setRange = Sheet1.Range("B" & iLine)
    Call subCodeFrame(setRange, lngColor, sBsel)

    'マクロの内容
    Set setRange = Sheet1.Range("C" & iLine)
    Call subCodeFrame(setRange, lngColor, sCsel)

    'ショートカットキー
    Set setRange = Sheet1.Range("D" & iLine)
    Call subCodeFrame(setRange, lngColor, sDsel)

    '設定Key
    Set setRange = Sheet1.Range("E" & iLine)
    Call subCodeFrame(setRange, lngColor, sEsel)

    'モジュール名
    Set setRange = Sheet1.Range("F" & iLine)
    Call subCodeFrame(setRange, lngColor, sFsel)

    '関数名
    Set setRange = Sheet1.Range("G" & iLine)
    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

■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
'*******************************************
'** 絶対値変換(未完成)
'*******************************************
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
'*******************************************
' 図形を最前面にする
'*******************************************
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
0
2
1

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
2