日常使う機能

Myaddon.xla

Option Explicit

Public Sub ExcelManner()
    Dim i As Integer
    
    For i = ActiveWorkbook.Worksheets.Count To 1 Step -1
        If ActiveWorkbook.Worksheets(i).Visible = xlSheetVisible Then
            ActiveWorkbook.Worksheets(i).Select
            ActiveWorkbook.Worksheets(i).Range("A1").Select
        End If
    Next i

End Sub

Public Sub AddArrow()
    Dim addressCell
    
    addressCell = Replace(ActiveCell.Address, "$", "")
    Dim rng As Range: Set rng = Range(addressCell)
    ActiveSheet.Shapes.AddShape(msoShapeDownArrow, rng.Left, rng.Top, 60, 30).Select

End Sub
Public Sub AddArrowRight()
    Dim addressCell
    
    addressCell = Replace(ActiveCell.Address, "$", "")
    Dim rng As Range: Set rng = Range(addressCell)
    ActiveSheet.Shapes.AddShape(msoShapeRightArrow, rng.Left, rng.Top, 30, 60).Select

End Sub
Public Sub AddWaku()

Dim addressCell

    addressCell = Replace(ActiveCell.Address, "$", "")
    Dim rng As Range: Set rng = Range(addressCell)
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, rng.Left, rng.Top, 60, 30)
    .Line.ForeColor.RGB = RGB(255, 0, 0)
    
    .Fill.Transparency = 1
    End With
    
End Sub
Public Sub AddPICBlackWaku()
Dim selectIMG As Shape

If Not Selection Is Nothing Then
    If TypeName(Selection) = "Picture" Then
    Set selectIMG = Selection.ShapeRange(1)
        With selectIMG.Line
            .ForeColor.RGB = RGB(0, 0, 0)
            .Weight = 1
        End With
    Else
        MsgBox "図形を選択してください。"
    End If
End If

End Sub
Public Sub setTitleNumber()
With Selection
        With .Font
            .Size = 12
            .Bold = True
        End With
        .HorizontalAlignment = xlLeft
    End With
End Sub

Public Sub ResizeSelectIMG()
Dim selectIMG As Shape

If Not Selection Is Nothing Then
    If TypeName(Selection) = "Picture" Then
        Set selectIMG = Selection.ShapeRange(1)
        selectIMG.LockAspectRatio = msoTrue
        selectIMG.Width = (26.66) * 28.3464567
        selectIMG.ZOrder msoSendToBack
        With selectIMG.Line
            .ForeColor.RGB = RGB(0, 0, 255)
            .Weight = 1
        End With
    Else
        MsgBox "図形を選択してください。"
    End If
End If

End Sub
Public Sub MacroName()

InputBox "利用したいマクロ名をコピーしてください。", "マクロ名", "AddArrow" & ";" & "AddWaku"
End Sub
Public Sub deleteRows()
Dim lastRow, i As Long
Dim selectRows As Long

If ActiveCell.Rows = 1 Then
    selectRows = 2
Else
    selectRows = ActiveCell.Rows
End If

lastRow = cells(Rows.Count, selectRows).End(xlUp).Row

For i = ActiveCell.Rows To lastRow
    Range(i + 2 & ":" & i + 2).Delete 'Range("行範囲1,行範囲2,行範囲3").Delete
Next i
End Sub

Public Sub AddFileName()
Dim fileName As String
fileName = Replace(Replace(Replace(ActiveWorkbook.Name, ".xlsx", ""), ".xls", ""), ".xlsm", "")

ActiveCell = fileName
End Sub
Public Sub AddFileNameTitle()
Dim fileName As String
fileName = Replace(Replace(Replace(ActiveWorkbook.Name, ".xlsx", ""), ".xls", ""), ".xlsm", "")
ActiveCell = "[" & Right(fileName, Len(fileName) - InStr(fileName, "_")) & "ー" & Left(fileName, InStr(fileName, "_") - 1) & "]"
End Sub
Public Sub AddSheetNameTitle()
Dim sheetsName As String
sheetsName = ActiveSheet.Name
ActiveCell = "＜" & sheetsName & "＞"
End Sub
Public Sub ALLSelectPIC()
Dim ws As Worksheet
Dim shp As Shape
Dim num
num = 0
 Set ws = ActiveSheet
 For Each shp In ws.Shapes
    shp.Select (False)
    num = num + 1
 Next shp
If num = 0 Then
    MsgBox "図形と画像が無い。"
End If
End Sub