Excel2016で複数ブックの複数シートを一括でページ設定を変更したいです。

500近いExcelのブックがあるのですが、パソコンを変えたところ、ページ設定がずれてしまい印刷がうまくいかない状態になってしまいました。
ページ設定で、1×1に収まるように設定したいのですが数が多いため、いろいろと調べて下記のようなVBSを見つけ調整しました。
ページ設定を変えたいシートは「提出」を含むシートなのですが、1つのブックに「提出」を含むシートが複数あると止まってしまいます。
この場合、どうしたらよいのでしょうか?

Option Explicit
Dim a, b, v, w, x, y, z
MsgBox("Start!")
Set v = CreateObject("Scripting.FileSystemObject")
Set w = v.GetFolder(".")
Set x = CreateObject("Excel.Application")
x.Application.DisplayAlerts = False
x.Visible = True
For Each a In w.Files
b = LCase(v.GetExtensionName(a.Name))
If b = "xls" or b = "xlsx" Then
Set y = x.Workbooks.Open(w & "\" & a.Name)
Set z = y.Worksheets("*提出*")
With z.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
y.SaveAs(w & "\" & a.Name)
y.Close
Set z = Nothing
Set y = Nothing
End If
Next
x.Quit
Set x = Nothing
Set w = Nothing

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2018/11/05 15:56:17
  • 終了:2018/11/06 10:30:07

ベストアンサー

id:kimuram No.2

kimuram回答回数21ベストアンサー獲得回数82018/11/05 23:37:03

”複数あると止まってしまう”とはどんなものかわからないのですが、では1個だけなら処理できるということのようですが、当方で試したところ、ワークシート名を"*提出*" で判定する処理はエラーとなって全く実行できませんでした。
それからシートは複数あるのも普通のことでしょうから、ここはシートを一つずつ順番に処理する形になるでしょう。
つまりシートの数分を、もう一段の For Each で処理することになります。
また、"*提出*"に相当する部分は、Instr関数で、シート名に含んでいるかを判定することにして、以下のようにしてみました。
どうでしょうか。


Option Explicit
Dim a, b, v, w, x, y, z
MsgBox ("Start!")
Set v = CreateObject("Scripting.FileSystemObject")
Set w = v.GetFolder(".")
Set x = CreateObject("Excel.Application")
x.Application.DisplayAlerts = False
x.Visible = True
For Each a In w.Files
b = LCase(v.GetExtensionName(a.Name))
If b = "xls" Or b = "xlsx" Then
Set y = x.Workbooks.Open(w & "\" & a.Name)
'Set z = y.Worksheets("*提出*") ' ←当方では、このワイルドカードは働かなかった

' =================
' ワークシートを一つずづ確認
For Each z In y.Worksheets
' シート名に"提出"を含むものを対象として処理
If Instr(z.Name,"提出")>0 then
With z.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End if
Next
' =================

y.SaveAs (w & "\" & a.Name)
y.Close
Set z = Nothing
Set y = Nothing
End If
Next
x.Quit
Set x = Nothing
Set w = Nothing


後はちょっと思うところですが、
SaveAsはどんなものだろうかと。
Saveで良いようにおもうけれど、保存先の指定が不要だし。
そして変更のないブックは上書き保存もしない方が気分としては良いので、変更状況を見てSaveを行うとか。
また処理状況をログとしてテキストファイルに書き出すのも確認に有効です。
でもまあ、一度限りの処理だと思うので手間かけるまでもないのでしょう。

id:kaemi

ご教授、ありがとうございます。
教えていただいたもので、できるようになりました。
保存に関しましては、ご指摘の通り1度限りなので、このまま実施させていただこうと思います。

2018/11/06 10:28:47

その他の回答(1件)

id:Z1000S No.1

Z1000S回答回数31ベストアンサー獲得回数212018/11/05 23:09:54

WorkSheetの指定をワイルドカードを使用しているのが問題のような気がします。

Set z = y.Worksheets("*提出*")


For Eachを使って、ワークシートの名前を個別にチェックして、処理対象のシートの場合のみ処理して、処理済みの場合は最後に保存すればよいのでは?

変数名を変えてありますが、こんな感じで出来ませんか?

        If sExtention = "xls" Or sExtention = "xlsx" Then
            Set wb = xlApp.Workbooks.Open(fld.Path & "\" & fl.Name)

            mustSave = False

            For Each ws In wb.Worksheets
                If ws.Name Like "*提出*" Then
                    With ws.PageSetup
                        .Zoom = False
                        .FitToPagesWide = 1
                        .FitToPagesTall = 1
                    End With

                    mustSave = True
                End If
            Next ws

            If mustSave Then
                wb.SaveAs (fld.Path & "\" & fl.Name)
            End If

            wb.Close

            Set wb = Nothing
        End If
id:kaemi

ご教授、ありがとうございます。
ファイル操作を繰り返す中に、シートの操作の繰り返しを入れるイメージでしょうか。
やってみます!

2018/11/06 10:27:42
id:kimuram No.2

kimuram回答回数21ベストアンサー獲得回数82018/11/05 23:37:03ここでベストアンサー

”複数あると止まってしまう”とはどんなものかわからないのですが、では1個だけなら処理できるということのようですが、当方で試したところ、ワークシート名を"*提出*" で判定する処理はエラーとなって全く実行できませんでした。
それからシートは複数あるのも普通のことでしょうから、ここはシートを一つずつ順番に処理する形になるでしょう。
つまりシートの数分を、もう一段の For Each で処理することになります。
また、"*提出*"に相当する部分は、Instr関数で、シート名に含んでいるかを判定することにして、以下のようにしてみました。
どうでしょうか。


Option Explicit
Dim a, b, v, w, x, y, z
MsgBox ("Start!")
Set v = CreateObject("Scripting.FileSystemObject")
Set w = v.GetFolder(".")
Set x = CreateObject("Excel.Application")
x.Application.DisplayAlerts = False
x.Visible = True
For Each a In w.Files
b = LCase(v.GetExtensionName(a.Name))
If b = "xls" Or b = "xlsx" Then
Set y = x.Workbooks.Open(w & "\" & a.Name)
'Set z = y.Worksheets("*提出*") ' ←当方では、このワイルドカードは働かなかった

' =================
' ワークシートを一つずづ確認
For Each z In y.Worksheets
' シート名に"提出"を含むものを対象として処理
If Instr(z.Name,"提出")>0 then
With z.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End if
Next
' =================

y.SaveAs (w & "\" & a.Name)
y.Close
Set z = Nothing
Set y = Nothing
End If
Next
x.Quit
Set x = Nothing
Set w = Nothing


後はちょっと思うところですが、
SaveAsはどんなものだろうかと。
Saveで良いようにおもうけれど、保存先の指定が不要だし。
そして変更のないブックは上書き保存もしない方が気分としては良いので、変更状況を見てSaveを行うとか。
また処理状況をログとしてテキストファイルに書き出すのも確認に有効です。
でもまあ、一度限りの処理だと思うので手間かけるまでもないのでしょう。

id:kaemi

ご教授、ありがとうございます。
教えていただいたもので、できるようになりました。
保存に関しましては、ご指摘の通り1度限りなので、このまま実施させていただこうと思います。

2018/11/06 10:28:47

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません