仕事で使えるマクロ集

仕事で使う用のExcelマクロ
あると便利

効率とかはほとんど考えてない
バグもあるかも

全てのシートのセル選択位置をA1にしてズームも合わせる

Public Sub ResetPositionAndZoom()

On Error Resume Next

    Dim zoom As Long        'ズームサイズ
    Dim i As Long           'ループカウンタ
    Dim sheetNumber As Long 'シート番号

    'ズームサイズを選択する
    zoom = CLng(InputBox("ズームサイズを選択してください[%]"))
    If (zoom = 0) Then
        Exit Sub
    End If
    
    'ズームと選択セルの位置を全シートに適用
    For sheetNumber = 1 To Sheets.Count
    
        Worksheets(sheetNumber).Select
        
        If (ActiveWindow.FreezePanes = True) Then
            'ウィンドウ枠固定をしている場合
            ActiveSheet.Cells(ActiveWindow.SplitRow + 1, ActiveWindow.SplitColumn + 1).Select
        End If
        'A1を選択
        ActiveSheet.Cells(1, 1).Select
        
        'ズームを設定
        ActiveWindow.zoom = zoom
    Next

    '左端のシートに移動
    Sheets(1).Select
    Exit Sub
End Sub

今開いているブックに既存のブックのシートを追加する

Public Sub UnionBook()
    Dim flag As Boolean
    Dim myBookName As String
    Dim beforeOpenBookList As New Collection
    Dim openBookList As New Collection
    Dim i As Long
    Dim j As Long
    
    Application.ScreenUpdating = False
    
    '自分の名前を取得する
    myBookName = ActiveWorkbook.Name
    
    'すでに開いているブックを覚える
    i = 1
    Do While i <= Workbooks.Count
        beforeOpenBookList.Add (Workbooks(i).Name)
        
        i = i + 1
    Loop
    
    '合体させるブックを選択する
    flag = Application.Dialogs(xlDialogOpen).Show
    If flag = False Then
        Exit Sub
    End If
    
    'コピー対象のブックの名前を取得する
    i = 1
    Do While i <= Workbooks.Count
        
        'コピー対象のブックか検査する
        j = 1
        flag = True
        Do While j <= beforeOpenBookList.Count
            If CStr(beforeOpenBookList(j)) = Workbooks(i).Name Then
                flag = False
                Exit Do
            End If
            j = j + 1
        Loop
        
        If flag = True Then
            openBookList.Add (Workbooks(i).Name)
        End If
        
        i = i + 1
    Loop
    
    'コピーしますよ
    i = 1
    
    Do While i <= openBookList.Count
        j = 1
        Do While j <= Workbooks(openBookList(i)).Sheets.Count
            
            'シートをコピーします
            Workbooks(openBookList(i)).Sheets(j).Copy After:=Workbooks(myBookName).Sheets(Workbooks(myBookName).Sheets.Count)
            
            j = j + 1
        Loop
        
        '終わったんで閉じます
        Workbooks(openBookList(i)).Close savechanges:=False
        
        i = i + 1
    Loop
    
    Application.ScreenUpdating = True
    
    Exit Sub
ERR:
    MsgBox "ごめん。できない。。。"
    Exit Sub
End Sub

数式バーの表示・非表示を切り替える*1

セル内にいっぱい文字列が入っていると数式バーがうざい
それを切り変える
個別のボタンに設定すると便利

Public Sub ChangeDisplayFormulaBar()
  If Application.DisplayFormulaBar = True Then
    Call DisableFormulaBar
  Else
    Call EnableFormulaBar
  End If
  Application.DisplayExcel4Menus = True
End Sub

数式バーを非表示にする

Private Sub DisableFormulaBar()
  Application.DisplayFormulaBar = False
End Sub

数式バーを表示する

Private Sub EnableFormulaBar()
  Application.DisplayFormulaBar = True
End Sub

正規表現で検索する*2

マクロ作るときにあると便利

Public Function RegexFind(strTargetText As String, strPutternText As String) As Boolean
    RegexFind = False
On ERR GoTo ERR:
    
    Dim reg As New RegExp
    
    If strTargetText = "" Or strPutternText = "" Then
        Exit Function
    End If
    
    reg.Pattern = strPutternText
    
    RegexFind = reg.Test(strTargetText)
    
    Exit Function
ERR:
    RegexFind = False
    Exit Function
End Function

正規表現で置換する*3

これもマクロ作るときにあると便利

Public Function RegexReplace(strTargetText As String, strPutternText As String, strReplaceText As String) As String
    RegexReplace = ""
On ERR GoTo ERR:
    
    Dim reg As New RegExp
    
    If strTargetText = "" Or strPutternText = "" Then
        Exit Function
    End If
    
    reg.Pattern = strPutternText
    
    RegexReplace = reg.Replace(strTargetText, strReplaceText)
    
    Exit Function
ERR:
    RegexReplace = ""
    Exit Function
End Function

*1:下の二つの関数も必要

*2:Microsoft VBScript Regular Expression 5.5の参照が必要

*3:Microsoft VBScript Regular Expression 5.5の参照が必要