気軽に楽しくプログラムと遊ぶ

自分が興味があってためになるかもって思う情報を提供しています。

Excelのちょっと面倒な作業を楽にするVBAマクロ

VBA

作業を楽にするマクロ一覧

以下のリンクで各マクロへジャンプできます。

下記サイトを参考にして、ショートカットを割り当てると便利に使えます。ご使用ください。
http://www.relief.jp/itnote/archives/001490.php

選択シートコピー

Sub 選択シートコピー()
'
' 選択シートコピー Macro
'
'
    ActiveSheet.Copy After:=Sheets(ActiveWorkbook.Worksheets.Count)
    Range("A1").Select
End Sub

アクティブブックの全シートのカーソルを左上移動

Excelを開いたときにカーソルがバラバラで参照しづらい時に使います。全シートのカーソルを左上に移動して、ブックを保存します。

Sub カーソル左上移動()
'
' カーソル左上移動 Macro
'

    Dim WS_Count As Integer
    Dim i As Integer
    
    ' Set WS_Count equal to the number of worksheets in the active
    ' workbook.
    WS_Count = ActiveWorkbook.Worksheets.Count
    
    ' Begin the loop.
    For i = 1 To WS_Count
        Worksheets(i).Select
        Cells(8, 1).Select '分割下領域もカーソルを左上へ移動
        Cells(1, 1).Select
    Next i
    
    Worksheets(1).Select
    ActiveWorkbook.Save
    
End Sub

選択範囲のセル範囲全体に罫線

Sub セル範囲全体に罫線()
'
' セル範囲全体に罫線 Macro
'
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With


End Sub

選択範囲のセル範囲全体に罫線解除

Sub セル範囲全体に罫線解除()
'
' セル範囲全体に罫線 Macro
'
    With Selection.Borders
        .LineStyle = xlNone
    End With


End Sub

コピーしたセルの値のみを貼り付ける

Sub 値貼り付け()
'
' 値貼り付け Macro
'
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

オブジェクト全選択

吹き出しとかコメントとか全てのオブジェクトを選択する。

Sub オブジェクト全選択()
'
' オブジェクト全選択 Macro
'
    ActiveSheet.DrawingObjects.Select

End Sub

選択しているオブジェクトを最背面にする

Sub 最背面()
'
' 最背面 Macro
'
    Selection.ShapeRange.ZOrder msoSendToBack
End Sub

VBAの修正差分を確認するためにモジュールをテキストに書き出す

Sub Module書出()
  ' 使用用途：VBAの修正差分確認用
  
  ' VBA モジュールの書き出し
  Dim Project, objxl As Object
  Dim DirName As String
  Const Path As String = "C:\tmp\"

  'Topディレクトリ作成
  If Dir(Path, vbDirectory) = "" Then
    MkDir Path
  End If
  
  For Each objxl In Application.Workbooks
    If objxl.Name = "PERSONAL.XLSB" Or objxl.Name = "B" Then
      GoTo Continue
    End If
      
    DirName = Path & Left(objxl.Name, Len(objxl.Name) - 4) & "\"
    MkDir DirName
    For Each Project In objxl.VBProject.VBComponents
      Project.Export DirName & Project.Name & ".bas"
    Next
Continue:
  Next
End Sub

選択シート複数コピー_連番シート名

Sub 選択シート複数コピー_連番シート名()
Prefix = "TCP"
CopySheetNum = 18
    
    For i = 1 To CopySheetNum
        ActiveSheet.Copy After:=Sheets(ActiveWorkbook.Worksheets.Count)
        Range("A1").Select
        ActiveSheet.Name = Prefix & i
    Next i
    
End Sub

シート内情報全クリア

Sub シート内情報全クリア()
'
' シート内情報全クリア Macro
' 文字列、表の枠組み、色づけ、フォント(11ptにする)を全クリアする
'
' Keyboard Shortcut: Ctrl+Shift+N
'
    Cells.Select
    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
    With Selection.Font
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .TintAndShade = 0
    End With
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.ClearContents
    Range("A1").Select
End Sub

空行の挿入

Sub 空行の挿入()
'
' 空行の挿入 Macro
' カーソルがある行に空行の挿入
'
' Keyboard Shortcut: Ctrl+i
'
    Dim rowNum As Long
    Dim address As String
    
    ' 選択位置を取得
    address = Selection.address
    ' 行番号を取得
    rowNum = Selection.Row
    
    Rows(rowNum & ":" & rowNum).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range(address).Select

End Sub

行削除

Sub 行削除()
'
' 行削除 Macro
' カーソルがある行を削除
'
' Keyboard Shortcut: Ctrl+Shift+d
'
    Dim rowNum As Long
    Dim address As String
    
    ' 選択位置を取得
    address = Selection.address
    ' 行番号を取得
    rowNum = Selection.Row
    
    Rows(rowNum & ":" & rowNum).Select
    Selection.Delete Shift:=xlUp
    
    Range(address).Select

End Sub

URLリンク化

Sub URLリンク化()
'
' URLリンク化 Macro
' URL文字列セルをリンク化して、下の行のセルに移動する
'
' Keyboard Shortcut: Ctrl+Shift+L
'
  Dim row_num As Long
  Dim col_num As Long
  Dim val As String
  
  row_num = ActiveCell.Row
  col_num = ActiveCell.Column
  val = ActiveCell.Value
    
  ActiveSheet.Hyperlinks.Add Anchor:=Cells(row_num, col_num), address:=val
  
  Cells(row_num + 1, col_num).Select
    
End Sub

ハイパーリンクを開く

Sub ハイパーリンクを開く()
'
' ハイパーリンクを開く Macro
' セル内ハイパーリンクを開く
'
' Keyboard Shortcut: Ctrl+Shift+H
'
    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
End Sub