Excelシートが増えたときにつかえるマクロのメモ

はじめに

IT系に限らず、ドキュメント作成にはExcel使うことが多いですね。
とくにExcelはシートを多く作りがちです。

意外とやりたいと思った機能がないので、基本的にVBA（マクロ）をやる必要があります。

しかし、マクロ有効ブックでは保存したくありません。
ということで、個人的メモ。(基本拾い物です）

マクロをどう使うか

1. Alt+F11を押してVBAの画面を表示。
2. F7を押して、コードを記入するウィンドウ表示。
3. コードをコピー＆ペースト。
4. F5で実行。
5. 実行したらコードをすべて消す。
6. VBAを閉じる。

すべてのシートシリーズ

すべてのシートのセルの選択をA1にする

Sub SetCellToA1ForAllSheets()
'ちらつき対策
Application.ScreenUpdating = False

Dim i As Long
 For i = 1 To Sheets.Count
  Dim s As Worksheet
  Set sheet = Sheets(i)
  sheet.Activate
  sheet.Range("A1").Select
 Next
End Sub

すべての非表示シートを再表示する

シートが増えるとシート間の移動が非常に大変ですね。
僕はよくその時点でいじらないものは、シートを非表示にします。
（シートをShift押しながら選択して右クリック>非表示）
最後に表示するときに使える。

複数選択して非表示はできるのに、再表示は複数選択できない不思議。

Sub SetVisibleForAllSheets()
'ちらつき対策
Application.ScreenUpdating = False

For Each sheet In Sheets
 sheet.Visible = True
Next sheet
End Sub

すべてのシートのウィンドウ枠の固定を解除する

もしもウィンドウ枠を固定しているシートがあったら困るってときは、
Ctrl+PageUp/PageDownして表示からいちいち変えていくのが面倒。

Sub ResetFreezePanes()
'ちらつき対策
Application.ScreenUpdating = False

  Dim sheet As Worksheet
  For Each sheet In Worksheets
      sheet.Activate
    If ActiveWindow.FreezePanes Then
    ActiveWindow.FreezePanes = False
    End If
  Next
End Sub

すべてのシートの白黒設定を解除

プリンタの設定はコントロールパネルから変えてあげてください。

Sub ResetBlackAndWhitePrint()
'ちらつき対策
Application.ScreenUpdating = False

  Dim sheet As Worksheet
  For Each sheet In Worksheets
      sheet.Activate
    If ActiveSheet.PageSetup.BlackAndWhite Then
    ActiveSheet.PageSetup.BlackAndWhite = False
    End If
  Next
End Sub

すべてのシートの印刷設定で横1ページにする

Sub SetWidthToFit1Page()
'ちらつき対策
Application.ScreenUpdating = False
For Each sheet In Sheets
  With sheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
  End With
Next sheet
End Sub

すべてのシートを改ページプレビュー表示にする

ついでに倍率も85%とかにしてみる。

Sub SetPageBreakPreviewToAll()
'ちらつき対策
Application.ScreenUpdating = False
  Dim sheet As Worksheet
  For Each sheet In Worksheets
      sheet.Activate
      ActiveWindow.View = xlPageBreakPreview
      ActiveWindow.Zoom = 85
  Next
End Sub

すべてのシートを標準のビュー表示にする

ついでに倍率も85%とかにしてみる。

Sub SetNormalViewToAll()
'ちらつき対策
Application.ScreenUpdating = False
  Dim sheet As Worksheet
  For Each sheet In Worksheets
      sheet.Activate
      ActiveWindow.View = xlNormalView
      ActiveWindow.Zoom = 85
  Next
End Sub

すべてのシートをページレイアウトビュー表示にする

ついでに倍率も85%とかにしてみる。

Sub SetPageLayoutViewToAll()
'ちらつき対策
Application.ScreenUpdating = False
  Dim sheet As Worksheet
  For Each sheet In Worksheets
      sheet.Activate
      ActiveWindow.View = xlPageLayoutView
      ActiveWindow.Zoom = 85
  Next
End Sub

なんでもかんでも、すべてのシートにマクロを適用する。

Sub MacroToAllSheets()
'ちらつき対策
Application.ScreenUpdating = False

　Dim Sheet As Worksheet
　　　For Each Sheet In Worksheets
　　　　　Sheet.Select
　　　　　Call マクロ名
　　　Next Sheet
End Sub

連番の名前のシートをコピーして作成

アクティブシート(今開いているシート）の後ろに、
特定の接頭語を付けた連番のコピーシートを作成します。
（例として、EV.0001～EV.0010)

Sub SequenceSheets()
'ちらつき対策
Application.ScreenUpdating = False

Dim Start_Num As Long
Dim End_Num As Long
Dim i As Long
Start_Num = 1
End_Num = 10
For i = Start_Num To End_Num
 'Sheets("Sheet1").Copy After:=ActiveSheet
 ActiveSheet.Copy After:=ActiveSheet
 ActiveSheet.Name = "EV." & Right("0000" & i, 4)
Next i
End Sub

シート名を連番に変更

アクティブシート(今開いているシート）の後ろのシートの名前を、
特定の接頭語を付けた連番に変更します。
（例として、EV.0001～EV.0010)

Sub SequenceNameSheet()
'ちらつき対策
Application.ScreenUpdating = False

Dim Now_Num As Long
Dim Start_Num As Long
Dim End_Num As Long
Dim i As Long
Now_Num = ActiveSheet.Index
Start_Num = 1
'End_Num = 10
End_Num =Worksheets.Count-3
For i = Start_Num To End_Num
 Sheets(Now_Num + i).Name = "EV." & Right("0000" & i, 4)
Next i
End Sub

セルをハイパーリンクに変換

特定のシート名（今回はテスト仕様）の特定のセル（列）を入力された値のシートへのハイパーリンクにします。
（例として、I8の列）

Sub AddHyperLink()
'ちらつき対策
Application.ScreenUpdating = False

 'Worksheets("テスト仕様").Hyperlinks.Delete
 Dim i As Long
    i = 8
    Do Until Range("I" & i).Value = ""
        Worksheets("テスト仕様").Hyperlinks.Add _
            Anchor:=Range("I" & i) _
            , Address:=ThisWorkbook.FullName _
            , SubAddress:="EV." & Right("0000" & Range("I" & i).Value, 4) & "!A1"
        i = i + 1
    Loop
End Sub

貼り付ける画像のサイズをリサイズ

(Author:Arai)thx!
貼り付ける画像のサイズを20cmにする（A4横に入る）
マクロ一覧からCtrl+qなどのショートカットキーを充てると便利！

Sub resizedPaste()
    ' 貼り付け
    ActiveSheet.Paste

    ' 縮小
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Width = 566.929133868571
End Sub

シート名一括置換

コピペしたら全部半角スペースと()がついて参照しずらいときに使いました
正規表現対応できたらもっと便利か？
RelaxToolだと結局１個ずつなので面倒
出展

Sub シート名置換()
    Dim ws As Worksheet
    Dim myFind As String
    Dim myReplace As String
    
    myFind = Application.InputBox("検索文字列は？", "シート名置換", Type:=2)
    myReplace = Application.InputBox("置換文字列は？", "シート名置換", Type:=2)
    
    For Each ws In ActiveWorkbook.Worksheets
        On Error Resume Next
        ws.name = Replace(ws.name, myFind, myReplace, 1, -1, 2)
    Next ws
End Sub

参考

とりあえずここまで