初心者向けExcelアドイン

私が新人時代に上司から貰ったExcelアドインを、時が経ち自分自身で思い出しながら作成したもの

Sub 文字列変換()
    Dim iRow                    As Long     '// 行位置
    Dim iCol                    As Long     '// 列位置
    Dim iRowMax                 As Long     '// 行数
    Dim iColMax                 As Long     '// 列数
    Dim sFormatAfter            As String   '// 変換後表示形式
    Dim lngSelectionRow         As Long
    Dim lngSelectionColumn      As Long
    Dim flg                     As Boolean
    
    Application.ScreenUpdating = False ' 画面描画を停止
    Application.DisplayAlerts = False  ' 警告表示を停止
   
    If TypeName(Selection) = "Range" Then
        sFormatAfter = "@"
    
        If Selection.Count = 1 Then
            Cells.Select
            flg = True
        End If
        
        '// 変換後の表示形式を設定
        Selection.NumberFormatLocal = sFormatAfter
    
        '// 行位置、列位置、行数、列数を取得
        iRow = Selection.Row
        iCol = Selection.Column
        iRowMax = iRow + Selection.Rows.Count - 1
        iColMax = iCol + Selection.Columns.Count - 1
    
        '// 選択セル範囲を列ごとにループ
        For iCol = iCol To iColMax
            If (Range(Cells(iRow, iCol), Cells(iRowMax, iCol)).Text <> "") Then
                '// 区切り位置設定
                Call Range(Cells(iRow, iCol), Cells(iRowMax, iCol)).TextToColumns
            End If
        Next
    
        If flg Then
            'セル選択の場合、A1へ移動
            Cells(1, 1).Select
        End If
    End If
    
    Application.ScreenUpdating = True ' 画面描画を再開
    Application.DisplayAlerts = True  ' 警告表示を再開
    
End Sub
Sub 表作成()

    Application.ScreenUpdating = False ' 画面描画を停止
    Application.DisplayAlerts = False  ' 警告表示を停止
    
    If TypeName(Selection) = "Range" Then
        ' 手動で罫線を引きたい範囲を選択してからマクロを実行する
        Dim rng As Range
        Set rng = Selection
    
        ' 罫線を引く
        With rng
            '外枠：実線、内枠：横破線
            .Borders.LineStyle = xlDash
            .BorderAround LineStyle:=xlContinuous
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
            End With
    
            ' 表の列数を計算する
            Dim numColumns As Long
            numColumns = .Columns.Count
    
            'ヘッダーの作成
            .Rows(1).Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Rows(1).Interior.ColorIndex = 34
        End With
    End If
    
    Application.ScreenUpdating = True ' 画面描画を再開
    Application.DisplayAlerts = True  ' 警告表示を再開

End Sub
Sub 方眼紙作成()
    Dim lngSelectionRow         As Long
    Dim lngSelectionColumn      As Long

    If TypeName(Selection) = "Range" Then
        '選択しているセル位置の格納
        lngSelectionRow = Selection.Row
        lngSelectionColumn = Selection.Column
        
        'Sheetの選択
        Cells.Select
        
        '方眼紙の作成
        Selection.ColumnWidth = 2.3     '自環境に合わせて幅の数値を設定
        Selection.RowHeight = 18        '自環境に合わせて高さの数値を設定
        
        '選択していた位置へカーソルを戻す
        Cells(lngSelectionRow, lngSelectionColumn).Select
    End If
End Sub
Sub 選択範囲比較()
    Dim rng1, rng2 As Range
    Dim lngRng1Row, lngRng2Row As Long
    Dim lngRng1Column, lngRng2Column As Long
    Dim iRow1                   As Long     '// 行位置
    Dim iCol1                   As Long     '// 列位置
    Dim iRowMax1                As Long     '// 行数
    Dim iColMax1                As Long     '// 列数
    Dim iRow2                   As Long     '// 行位置
    Dim iCol2                   As Long     '// 列位置
    Dim iRowMax2                As Long     '// 行数
    Dim iColMax2                As Long     '// 列数

    Application.ScreenUpdating = False ' 画面描画を停止

    If TypeName(Selection) = "Range" Then
        '選択範囲が2つあるか判定
        If Selection.Areas.Count = 2 Then
            Set rng1 = Selection.Areas(1)
            Set rng2 = Selection.Areas(2)
            
            '2つの選択範囲が同じ大きさか判定
            If rng1.Rows.Count = rng2.Rows.Count And rng1.Columns.Count = rng2.Columns.Count Then
                rng2.Interior.ColorIndex = 0
                For i = 1 To rng1.Cells.Count
                    'セルの値を比較
                    If rng1.Cells(i) <> rng2.Cells(i) Then
                        '異なる場合、2つ目の範囲のセルを色付け
                        rng2.Cells(i).Interior.ColorIndex = 38
                    End If
                Next
            Else
                MsgBox "同じ大きさで選択してください"
            End If
        Else
            MsgBox "2つの範囲を選択してください"
        End If
    Else
        MsgBox "セルを選択してください"
    End If
    
    Application.ScreenUpdating = True ' 画面描画を再開
    
End Sub
Sub 画像縮小()

    ' 画像が選択されているか
    If VarType(Selection) = vbObject Then
        '縦横比はそのままに
        '指定した倍率に縮小
        Selection.ShapeRange.LockAspectRatio = msoTrue
        Selection.ShapeRange.Height = Selection.ShapeRange.Height * 0.775
    End If
    
End Sub
Sub 文字強調()

    Dim rng As Range
    
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        '赤太字の場合
        If rng.Font.ColorIndex = 3 And rng.Font.Bold = True Then
            '黒細字に
            rng.Font.ColorIndex = 1
            rng.Font.Bold = False
        '上記以外の場合
        Else
            '赤太字に
            rng.Font.ColorIndex = 3
            rng.Font.Bold = True
        End If
    End If
End Sub