こんにちは！ 健史(たけふみ)です。
Excelで複数のシートを作成したファイル、例えば製品テストのエビデンスを膨大なテストパターンごとにシートを分けて作成したとき、
・表示倍率を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.Ctrl＋Vで貼り付けてF5で実行します。
実行後は、シート１がカレントになり、全てのシートがカーソルは"A1"に位置づき、表示倍率は100%になっています。
5.[上書き保存]にて「マクロなしのブックとして保存」する[はい(Y)]をクリックします。
該当Excel上にマクロを作成しましたが、拡張子に[xlsm]が使用できるバージョンであれば、マクロを一時的に実行して、マクロを除外して上書き保存できます。
マクロ専用ファイルから実行する
マクロ専用ファイルのシート１に「対象フォルダ」や「表示倍率」を指定して実行します。
「対象ファルダ」内のExcelファイル全てを対象に処理します。また「対象ファイル」を指定すれば該当ファイルだけを処理します。
1.Excelを起動し、シート１に以下を貼り付けます。
ドラッグ＆コピー後に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)
'シート１の設定値をチェック
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
'シート２がなければ追加
If excel0.Sheets.Count = 1 Then
excel0.Sheets.Add(After:=excel0.Sheets(excel0.Sheets.Count)).Name = "ファイル一覧"
End If
'ファイル名情報をシート２へ格納
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
'シート２のファイルを読み込み処理し上書き保存
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
補足です。
◇留意点
・このマクロ＝プログラムでは、カーソル設定、表示倍率を変更するのみで、データは更新しません。
・しかしファイルの破損など心配な場合は、実行前に対象フォルダの内容をバックアップしておきます。
◇処理概要
・表示倍率を設定すれば変更します。設定しなければ表示倍率は変更しません。
◇その他
・このマクロ＝プログラムでは、当ファイルのシート２を使用します。
・そのため、当ファイルにシート２が無ければ自動で作成し、あればクリアします。
最後に
ちょっとしたことですが、ドキュメントを受け取る側が望んでなくても揃っていれば、開いたときに好印象を感じるかもしれません。
あなた自身の評価が、あなたの組織の評価が上がるかもしれせん。
シート数が少なかったり対象ファイルが少なければ手作業で調整できますが、手作業で行うと漏れがあったり「ファイルを開いて、シート一つひとつを遷移して・・・」とストレスもかかります。
参考にして頂ければと思います。
コメント