Excelの倍率・アクティブセル変更マクロ

ディレクトリ内に存在するエクセルファイルの、セルと倍率を設定するマクロ

概要

このマクロは、特定のフォルダ内にあるすべてのExcelワークブックを開き、各シートの表示倍率を変更し、指定されたセルに移動するものです。マクロが記載されているワークブックのSheet1 の A1 セルと A2 セルに基づいて、他のワークブックで同様の操作を行います。

このマクロはWindows環境とMac環境の両方で動作するようにカスタマイズ可能です。ここでは、Windows環境向けのコードを紹介します。

マクロの動作概要

1. フォルダ内のすべてのExcelワークブックを開く:

   • 指定されたフォルダ内にある .xls, .xlsx, .xlsm ファイルを順番に開きます。

2. 各シートの倍率と指定セルを設定:

   • マクロが記載されているワークブックの Sheet1 の A1 セルに記載されたセルアドレスに基づき、各シートでそのセルに移動します。
   • 同じく Sheet1 の A2 セルに記載された数値を読み取り、各シートの表示倍率を設定します。

3. ワークブックを上書き保存して閉じる:

   • 変更を保存して、次のワークブックを処理します。

コード

以下がWindows環境用のVBAコードです。

Sub OpenAllWorkbooksInSameFolder_Windows()
    Dim currentWorkbookPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws: Worksheet
    Dim targetCell: String
    Dim zoomLevel: Integer
    
    ' 現在のワークブックのパスを取得
    currentWorkbookPath = ThisWorkbook.Path
    
    ' このワークブックのSheet1のA1セルの内容を取得
    targetCell = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
    
    ' このワークブックのSheet1のA2セルの内容を取得（倍率）
    zoomLevel = ThisWorkbook.Sheets("Sheet1").Range("A2").Value
    
    ' フォルダ内の最初のエクセルファイルを取得（すべてのエクセル形式を対象）
    fileName = Dir(currentWorkbookPath & "\*.xls*")
    
    ' すべてのエクセルファイルを順に開く
    Do While fileName <> ""
        ' マクロが含まれるワークブックは無視する
        If fileName <> ThisWorkbook.Name Then
            ' ワークブックを開く
            Set wb = Workbooks.Open(currentWorkbookPath & "\" & fileName)
            
            ' すべてのシートを順に処理
            For Each ws In wb.Sheets
                ' シートをアクティブにする
                ws.Activate
                
                ' シートの倍率を設定する
                ActiveWindow.Zoom = zoomLevel
                
                ' 取得したセルアドレスに移動
                ws.Range(targetCell).Select
            Next ws
            
            ' 最初のシートを再度アクティブにする
            wb.Sheets(1).Activate
            
            ' 上書き保存する
            On Error Resume Next
            wb.Save
            If Err.Number <> 0 Then
                MsgBox "ファイルの保存中にエラーが発生しました: " & fileName, vbExclamation
                Err.Clear
            End If
            On Error GoTo 0
            
            ' ワークブックを閉じる
            wb.Close
        End If
        
        ' 次のファイルを取得
        fileName = Dir
    Loop
End Sub