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

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

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

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

#マクロをどう使うか
1. Alt+F11を押してVBAの画面を表示。
1. F7を押して、コードを記入するウィンドウ表示。
1. コードをコピー＆ペースト。
1. F5で実行。 
1. 実行したらコードをすべて消す。
1. 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だと結局１個ずつなので面倒
[出展](https://kuroeveryday.blogspot.com/2013/11/excelSheetReplace.html)

```
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
```

#参考

とりあえずここまで