EXCEL VBA

Excel-VBA 全シートのカーソル位置、表示倍率を統一する

EXCEL VBA

こんにちは! 健史(たけふみ)です。

Excelで複数のシートを作成したファイル、例えば製品テストのエビデンスを膨大なテストパターンごとにシートを分けて作成したとき、

・カーソルの位置をすべて"A1"にしたい、しかも開いたときには1番目のシートにしたい
・表示倍率を100%など一定に揃えたい

ということありませんか。

多くのシートを作成したExcelファイルを客先や上司・同僚などへ提出する際、自分が受け取る側で内容を精査しなければならないときのことを考えると、受け取る側のことを考えて保存したいものです。

スポンサーリンク

既存Excelファイル上でマクロを実行する

後述しますが実行後、拡張子に[xlsm]が使用できるバージョンであれば、上書き保存するときにはマクロを含めず拡張子は[xlsx]のまま保存できます。

1.以下のプログラムをコピーします。

    Dim sht As Long
    For sht = Sheets.Count To 1 Step -1 '最後尾のシートから前へ、最後は先頭シートで終了
        Sheets(sht).Activate
        Sheets(sht).Range("A1").Select
        ActiveWindow.Zoom = 100
    Next

2.対象のExcelファイルを開きます。拡張子は[.xlsm]でなくてもOKです。

3.Alt+F8でVBAを起動し、マクロ名には"temp"など入力し[作成(C)]をクリックします。

4.CtrlVで貼り付けてF5で実行します。

実行後は、シート1がカレントになり、全てのシートがカーソルは"A1"に位置づき、表示倍率は100%になっています。

5.[上書き保存]にて「マクロなしのブックとして保存」する[はい(Y)]をクリックします。

該当Excel上にマクロを作成しましたが、拡張子に[xlsm]が使用できるバージョンであれば、マクロを一時的に実行して、マクロを除外して上書き保存できます。

マクロ専用ファイルから実行する

マクロ専用ファイルのシート1に「対象フォルダ」や「表示倍率」を指定して実行します。

「対象ファルダ」内のExcelファイル全てを対象に処理します。また「対象ファイル」を指定すれば該当ファイルだけを処理します。

1.Excelを起動し、シート1に以下を貼り付けます。

ドラッグ&コピー後にExcelに貼り付けるとき、[形式を選択して貼り付ける]-[テキスト]で貼り付けます。(セル[A1]で[右クリック]、[形式を選択して貼り付ける]-[テキスト])を指定します。

項目	設定値	備考
対象フォルダ	C:\TEMP01\50.エビデンス	
対象ファイル		設定時のみ対象ファイルだけ処理する
表示倍率	100	10~400、指定時のみ変更する

2.Alt+F8でVBAを起動し、マクロ名には"temp"など入力し[作成(C)]をクリックします。

'対象ファルダから読み込むファイルを指定。Excelのみにする場合は"\*.xlsx"や"\*.xls"
    Const cnsDir = "\*.xls*"
'エクセルシートを複数同時に使うので変数として定義
    Dim excel0 As Workbook
    Dim excel1 As Workbook
'変数定義
    Dim ix0_2, ix0_2_max, sht As Long
    Dim strPath1, strFile1, strFilename As String
    Dim numZoom As Long
'変数:excel1に起動した(この)ファイルを設定
    Set excel0 = ActiveWorkbook
'起動した(この)ファイルのシートからワーク領域へ取り込み
    strPath1 = excel0.Sheets(1).Cells(2, 2)
    strFile1 = excel0.Sheets(1).Cells(3, 2)
    numZoom = excel0.Sheets(1).Cells(4, 2)
'シート1の設定値をチェック
    If Dir(strPath1, vbDirectory) = "" Then
        MsgBox "対象フォルダがありません!"
        Exit Sub
    End If
'
    If strFile1 <> "" Then
       If Dir(strPath1 & "\" & strFile1, vbDirectory) = "" Then
           MsgBox "対象ファイルがありません!"
           Exit Sub
        End If
    End If
'
    If excel0.Sheets(1).Cells(4, 2) = "" Then
        numZoom = 0
    Else
        If IsNumeric(excel0.Sheets(1).Cells(4, 2)) = True Then
            Select Case excel0.Sheets(1).Cells(4, 2)
            Case 10 To 400
                numZoom = excel0.Sheets(1).Cells(4, 2)
            Case Else
                MsgBox "表示倍率が設定可能な値ではありません!"
                Exit Sub
            End Select
        Else
            MsgBox "表示倍率が数字ではありません!"
            Exit Sub
        End If
    End If
'シート2がなければ追加
    If excel0.Sheets.Count = 1 Then
        excel0.Sheets.Add(After:=excel0.Sheets(excel0.Sheets.Count)).Name = "ファイル一覧"
    End If
'ファイル名情報をシート2へ格納
    excel0.Sheets(2).Cells.Clear
    excel0.Sheets(2).Cells(1, 1) = "フォルダ名"
    excel0.Sheets(2).Cells(1, 2) = "ファイル名"
    ix0_2 = 1
    If strFile1 = "" Then
        strFilename = Dir(strPath1 & cnsDir, vbNormal)
        Do While strFilename <> ""
             ix0_2 = ix0_2 + 1
             excel0.Sheets(2).Cells(ix0_2, 1) = strPath1 & "\" & strFilename
             excel0.Sheets(2).Cells(ix0_2, 2) = strFilename
             strFilename = Dir()
        Loop
    Else
         ix0_2 = ix0_2 + 1
         excel0.Sheets(2).Cells(ix0_2, 1) = strPath1 & "\" & strFile1
         excel0.Sheets(2).Cells(ix0_2, 2) = strFile1
    End If
'シート2のファイルを読み込み処理し上書き保存
    ix0_2_max = ix0_2
    For ix0_2 = 2 To ix0_2_max
        Set excel1 = Workbooks.Open(excel0.Sheets(2).Cells(ix0_2, 1))
        For sht = Sheets.Count To 1 Step -1
            excel1.Sheets(sht).Activate
            excel1.Sheets(sht).Range("A1").Select
            If numZoom <> 0 Then
                ActiveWindow.Zoom = numZoom
            End If
        Next
        excel1.Save
    Next
'終了処理
    excel0.Save
    MsgBox "処理終了!"
    Application.Quit


補足です。

◇留意点
・このマクロ=プログラムでは、カーソル設定、表示倍率を変更するのみで、データは更新しません。
・しかしファイルの破損など心配な場合は、実行前に対象フォルダの内容をバックアップしておきます。

◇処理概要
・表示倍率を設定すれば変更します。設定しなければ表示倍率は変更しません。

◇その他
・このマクロ=プログラムでは、当ファイルのシート2を使用します。
・そのため、当ファイルにシート2が無ければ自動で作成し、あればクリアします。

最後に

ちょっとしたことですが、ドキュメントを受け取る側が望んでなくても揃っていれば、開いたときに好印象を感じるかもしれません。

あなた自身の評価が、あなたの組織の評価が上がるかもしれせん。

シート数が少なかったり対象ファイルが少なければ手作業で調整できますが、手作業で行うと漏れがあったり「ファイルを開いて、シート一つひとつを遷移して・・・」とストレスもかかります。

参考にして頂ければと思います。

EXCEL VBA
スポンサーリンク
- 面白かったらシェアお願いします! -
健史をフォローする
自分で改善

コメント