常用Excelマクロ

よく使うマクロまとめ

Sub ふきだし追加オレンジ()

 ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, ActiveCell.Left, _
 ActiveCell.Top, 130, 60).Select
 With Selection.ShapeRange.Fill
 .Visible = msoTrue
 .ForeColor.RGB = RGB(255, 255, 255)
 .Transparency = 0
 .Solid
 End With
 
    '背景
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 192, 0)
        .Transparency = 0
        .Solid
    End With
    
    '枠線
    With Selection.ShapeRange.Line
        .Visible = msoFalse
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
    End With
    
    
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
        msoAlignLeft
    
    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
        .Solid
    End With



 'サイズ
 Selection.ShapeRange.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
 Selection.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromBottomRight
 '影
 Selection.ShapeRange.Shadow.Type = msoShadow23

 
 '文字位置
 Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
 Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorNone
 
 Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "text"
 
 '吹き出しの矢印場所
 Selection.ShapeRange.Adjustments.Item(1) = -0.7 '左右
 Selection.ShapeRange.Adjustments.Item(2) = 0.3  '上下

End Sub
Sub ふきだし追加ピンク()


 'Activeセルの値取得
 Dim retstr
 retstr = ""
 Dim str
 str = ""
'選択されているセルを取得して順番に処理する
  For Each Rng In Selection
    str = range(Rng.Address(False, False)).Value
    retstr = retstr + str + ":"
  Next Rng
 
 
 
 ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, ActiveCell.Left, _
 ActiveCell.Top, 130, 60).Select
 With Selection.ShapeRange.Fill
 .Visible = msoTrue
 .ForeColor.RGB = RGB(255, 255, 255)
 .Transparency = 0
 .Solid
 End With
 
    '背景
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 153, 204)
        .Transparency = 0
        .Solid
    End With
    
    '枠線
    With Selection.ShapeRange.Line
        .Visible = msoFalse
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
    End With
    
    '影
    Selection.ShapeRange.Shadow.Type = msoShadow23

    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
        msoAlignLeft
    
    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
        .Solid
    End With



 'サイズ
 Selection.ShapeRange.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
 Selection.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromBottomRight
 
 
 '文字位置
 Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
 Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorNone
 
 Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = retstr
 
 '吹き出しの矢印場所
 Selection.ShapeRange.Adjustments.Item(1) = -0.7 '左右
 Selection.ShapeRange.Adjustments.Item(2) = 0.3  '上下

End Sub

Sub 名前定義表示()

Dim name As Object
Dim i As Long
For Each name In Names
If name.Visible = False Then
name.Visible = True
i = i + 1
End If
Next
End Sub

Public Sub 全シート左上セル選択()
  On Error Resume Next

  ' 画面更新の停止
  Application.ScreenUpdating = False

  ' 全シート分実行
  Dim i As Integer

  For i = 1 To Worksheets.Count

  ' シートをアクティブ化
  Worksheets(i).Activate

  ' 左上にスクロール
  Dim j As Integer
  For j = 1 To Windows(1).Panes.Count
  Windows(1).Panes(j).ScrollColumn = 1
  Windows(1).Panes(j).ScrollRow = 1
  Next

  ActiveSheet.Cells(1, 1).Select ' 左上を選択
  'ActiveWindow.View = xlPageBreakPreview ' 改ページプレビュー
  ActiveWindow.Zoom = 100 ' 倍率
  'ActiveWindow.DisplayGridlines = False ' 枠線の非表示
  Next

  ' 1番目のシートをアクティブ化
  Worksheets(1).Activate

  ' 保存
  ActiveWorkbook.Save

  ' 画面更新の再開
  Application.ScreenUpdating = True
End Sub


Sub シート名振り直し()
  On Error Resume Next
  ' 画面更新の停止
  Application.ScreenUpdating = False
  ' 全シート分実行
  Dim i As Integer
  For i = 1 To Worksheets.Count
  ' シートをアクティブ化
  Worksheets(i).Activate
  ' シート名変更
  ActiveSheet.Name = i
  Next
  ' 1番目のシートをアクティブ化
  Worksheets(1).Activate
  　
  ' 画面更新の再開
  Application.ScreenUpdating = True
End Sub


Sub クリップボードからデータを取得する()
    ActiveSheet.Range("A1").Copy
    
    With New MSForms.DataObject
        .GetFromClipboard    ''変数のデータをDataObjectに格納する
        MsgBox .GetText
    End With
    Application.CutCopyMode = False
End Sub


Sub シート名取得()
    Dim s
    Dim str
    str = ""
    For Each s In ActiveWindow.SelectedSheets
        Debug.Print (s.name)
        str = str & s.name & vbLf
    Next s
    UserForm1.TextBox1.Value = str
    UserForm1.Show

End Sub


Sub ウィンドウの非表示再表示()
Dim window1 As Window
Set window1 = Application.ActiveWindow

    window1.Visible = False
    window1.Visible = True
End Sub


Public Sub シート再表示()
For Each s In Sheets: s.Visible = True: Next
End Sub


Public Sub シート大量追加()
    UserForm2.Show
End Sub

'''''''
'UserForm2でボタン押された時
'''''''
Private Sub CommandButton1_Click()

    Dim xx
    xx = Split(TextBox1.Text, vbLf)
    
    
    For i = 0 To UBound(xx) Step 1
        If xx(i) <> "" Then
            Worksheets().Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.name = xx(i)
            ActiveWindow.DisplayGridlines = False
            ActiveSheet.Tab.Color = 16711680
        End If
    Next
    
    Unload UserForm2

End Sub