仕事で使えるマクロ集
仕事で使う用の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