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
No.2
27
11
”複数あると止まってしまう”とはどんなものかわからないのですが、では１個だけなら処理できるということのようですが、当方で試したところ、ワークシート名を"*提出*" で判定する処理はエラーとなって全く実行できませんでした。
それからシートは複数あるのも普通のことでしょうから、ここはシートを一つずつ順番に処理する形になるでしょう。
つまりシートの数分を、もう一段の 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
No.1
3927
WorkSheetの指定をワイルドカードを使用しているのが問題のような気がします。
Set z = y.Worksheets("*提出*")
For Eachを使って、ワークシートの名前を個別にチェックして、処理対象のシートの場合のみ処理して、処理済みの場合は最後に保存すればよいのでは？
変数名を変えてありますが、こんな感じで出来ませんか？
26
22
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
ご教授、ありがとうございます。
ファイル操作を繰り返す中に、シートの操作の繰り返しを入れるイメージでしょうか。
やってみます！
No.2
2711
ここでベストアンサー
”複数あると止まってしまう”とはどんなものかわからないのですが、では１個だけなら処理できるということのようですが、当方で試したところ、ワークシート名を"*提出*" で判定する処理はエラーとなって全く実行できませんでした。
それからシートは複数あるのも普通のことでしょうから、ここはシートを一つずつ順番に処理する形になるでしょう。
つまりシートの数分を、もう一段の 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
ご教授、ありがとうございます。
教えていただいたもので、できるようになりました。
保存に関しましては、ご指摘の通り1度限りなので、このまま実施させていただこうと思います。
2
ご教授、ありがとうございます。
2018/11/06 10:28:47教えていただいたもので、できるようになりました。
保存に関しましては、ご指摘の通り1度限りなので、このまま実施させていただこうと思います。