追加したのは印刷する枚数が1枚だった時は処理を行わない。
あと処理対象のデータが何枚の印刷枚数データなのかを表示するために2列目に現れるように更に追加
それとシート名も変えないといけなかったんだわ＾＾； コピペして警告で気付いた。盲点だった(´・ω・`)
Option Explicit
'ページ設定のステータス受け取り箱
Dim para1 As String
Dim para2 As String
Dim para3 As String
Dim para4 As String
Dim para5 As String
Dim para6 As String
Dim para7 As String
'幅設定の結果の受け取り箱
Dim para8 As String
Dim clm As Variant
'処理シートに記入されている設定の受け取り箱
Dim haba1 As String
Dim page1 As String
Dim page2 As String
Dim page3 As String
'処理したデータ数
Dim num As Integer
'印刷されるページの枚数
Dim p_num As Integer
Sub pageset() 'ユーザーが指定したディレクトリ内にあるxlsデータ全てのページ設定と幅設定を変更する
Dim wb As Workbook
Dim strFnm As String
Dim strDir As String
Dim strDir2 As String
Dim toolwb As Workbook
Dim i As Integer
Dim AWN As String
Dim ShtCnt As Integer
Dim ShellApp As Object
Dim SaveFolder As Object
Dim TargetFolder As Object
'書き出すリスト部分をクリアにする
Call clear1
'このツールの情報を取得
Set toolwb = ThisWorkbook
'処理をするディレクトリを決める
Set ShellApp = CreateObject("Shell.Application")
Set TargetFolder = ShellApp.BrowseForFolder(0, "処理を行うフォルダを選択してください。", 1)
If TargetFolder Is Nothing Then Exit Sub
'エラーチェック
If ThisWorkbook.Path = TargetFolder.items.Item.Path Then
MsgBox "このツールと同じフォルダにあるデータは処理できません。"
Exit Sub
End If
'選択されたフォルダ内にxlsデータがあるか有無チェック
With Application.FileSearch
.NewSearch
.Filename = "*.xls" '”ABC*.xls"なども可能
.FileType = msoFileTypeAllFiles
.LookIn = TargetFolder.items.Item.Path '指定フォルダ
.SearchSubFolders = False
.Execute '検索実行
'検索結果が0の場合終了
If .FoundFiles.Count = 0 Then
MsgBox "選択したフォルダの中にはxlsデータはありません。"
Exit Sub
End If
End With
'保存するディレクトリを決める
Set SaveFolder = ShellApp.BrowseForFolder(0, "保存先フォルダを選択してください。", 1)
If SaveFolder Is Nothing Then Exit Sub
'処理を行うディレクトリ
strDir = TargetFolder.items.Item.Path
strDir2 = SaveFolder.items.Item.Path
'ユーザーが指定した幅設定の数値を代入
haba1 = Cells(2, 6).Value
'カンマ区切りで配列に収める
clm = Split(haba1, ",")
'チェック
If Right(haba1, 1) = "," Then
MsgBox "幅設定の最後に , があります。取り除いてください。"
Exit Sub
End If
'ユーザーが指定したページ設定(シート)を代入
page1 = Cells(4, 8).Value
page2 = Cells(4, 9).Value
page3 = Cells(4, 10).Value
'ツールの一覧シートにターゲットフォルダの場所を記入
Cells(5, 5).Value = strDir
'処理を行う対象データ
strFnm = Dir(strDir & "\*.xls")
'警告ウインドウ非表示
Application.ScreenUpdating = False
i = 1
'処理開始
Do Until strFnm = ""
Set wb = Workbooks.Open(strDir & "\" & strFnm)
'処理内容
AWN = Left(wb.Name, Len(wb.Name) - 4)
ChDir (strDir2)
'処理前のステータスをリストに書き留める
toolwb.Activate
Cells(i + 9, 2).Value = Application.ExecuteExcel4Macro("get.document(50)")
Cells(i + 9, 3).Value = wb.Name
Call para_in(wb)
Call page_status(i + 9, 4)
'変更処理を実行する
wb.Activate
'処理するシートの枚数を取得
p_num = Application.ExecuteExcel4Macro("get.document(50)")
'印刷される枚数が1枚の場合、ページ設定は行わない。
If Application.ExecuteExcel4Macro("get.document(50)") > 1 Then
Call page_status_change
End If
'■幅設定欄が空白の場合、幅調整は行はない
If haba1 <> "" Then
Call haba
End If
'処理後のステータスを書き留める
toolwb.Activate
Call para_in(wb)
Call page_status(i + 9, 11)
Cells(i + 9, 18).Value = para8
Cells(i + 9, 2).Value = p_num
'処理を行ったデータを保存する
wb.Activate
ActiveWorkbook.Close savechanges:=True _
, Filename:=AWN & "_" & "pageset" & ".xls"
i = i + 1
strFnm = Dir() '次のファイル名
Loop
Application.ScreenUpdating = True
'処理したデータ数を代入
num = i - 1
Range("T2").Value = num
'処理チェック
Call check
MsgBox "処理が完了しました。" _
& vbNewLine & " 処理データ数：" & Range("T2").Value & " ファイル" _
& vbNewLine & "ページ設定した数：" & Range("T3").Value & " ファイル" _
& vbNewLine & " 幅調節した数：" & Range("T4").Value & " ファイル"
End Sub
Sub page_status(GYO As Integer, RETU As Integer) 'ページ設定のステータスを書き出し
If para1 = "1" Then
Cells(GYO, RETU).Value = "縦向き"
Else: Cells(GYO, RETU).Value = "横向き"
End If
Cells(GYO, RETU + 1).Value = para2
Cells(GYO, RETU + 2).Value = para3
Cells(GYO, RETU + 3).Value = para4
Cells(GYO, RETU + 4).Value = para5
Cells(GYO, RETU + 5).Value = para6
Cells(GYO, RETU + 6).Value = para7
End Sub
Sub para_in(wbook As Workbook) 'パラメータを変数に代入
para1 = CStr(wbook.ActiveSheet.PageSetup.Orientation)
para2 = CStr(wbook.ActiveSheet.PageSetup.Zoom)
para3 = CStr(wbook.ActiveSheet.PageSetup.FitToPagesWide)
para4 = CStr(wbook.ActiveSheet.PageSetup.FitToPagesTall)
para5 = CStr(wbook.ActiveSheet.PageSetup.PrintArea)
para6 = CStr(wbook.ActiveSheet.PageSetup.PrintTitleRows)
para7 = CStr(wbook.ActiveSheet.PageSetup.PrintTitleColumns)
End Sub
Private Sub page_status_change() 'ページ設定の変更処理
With ActiveSheet.PageSetup
'フラッシュペーパー化する時のステータス(ページ)
.Orientation = 2 '印刷の向きを横にする
.Zoom = False '拡大縮小印刷設定を「次のページ数にあわせて印刷」に変更
.FitToPagesWide = 1 '上記のページ数横幅設定
.FitToPagesTall = False '同じく縦幅設定
'フラッシュペーパー化する時のステータス(シート)
If page1 <> "" Then
.PrintArea = page2 '印刷領域の設定
End If
If page2 <> "" Then
.PrintTitleRows = page2 '行タイトルの設定
End If
If page3 <> "" Then
.PrintTitleColumns = page3 '列タイトルの設定
End If
End With
End Sub
Private Sub haba()
Dim j As Long
Dim before_haba As Single
Dim after_haba As Single
Dim finish_haba As Single
para8 = ""
For j = 0 To UBound(clm)
before_haba = Columns("" & clm(j) & ":" & clm(j) & "").ColumnWidth
'幅の自動調整+微調整
Columns("" & clm(j) & ":" & clm(j) & "").EntireColumn.AutoFit
after_haba = Columns("" & clm(j) & ":" & clm(j) & "").ColumnWidth
Columns("" & clm(j) & ":" & clm(j) & "").ColumnWidth = after_haba - 1
after_haba = Columns("" & clm(j) & ":" & clm(j) & "").ColumnWidth
'変更した幅が変更前よりも小さくなってしまった(および一文字しか隠れていない[+1.0])場合元に戻す
If after_haba < before_haba + 1 Then
Columns("" & clm(j) & ":" & clm(j) & "").ColumnWidth = before_haba
End If
'最終幅の数値取得
finish_haba = Columns("" & clm(j) & ":" & clm(j) & "").ColumnWidth
If para8 = "" Then
If finish_haba <> before_haba Then para8 = "修整"
End If
'初期化
before_haba = 0
after_haba = 0
finish_haba = 0
Next j
End Sub
Sub SheetCopy() 'ユーザーが指定したディレクトリ内にあるxlsデータ全てにシート分割処理を行う
Dim wb As Workbook
Dim strFnm As String
Dim strDir As String
Dim strDir2 As String
Dim i As Integer
Dim AWN As String
Dim ShtCnt As Integer
Dim ShellApp As Object
Dim SaveFolder As Object
Dim TargetFolder As Object
'処理をするディレクトリを決める
Set ShellApp = CreateObject("Shell.Application")
Set TargetFolder = ShellApp.BrowseForFolder(0, "処理を行うフォルダを選択してください。", 1)
If TargetFolder Is Nothing Then Exit Sub
'エラーチェック
If ThisWorkbook.Path = TargetFolder.items.Item.Path Then
MsgBox "このツールと同じフォルダにあるデータは処理できません。"
Exit Sub
End If
'選択されたフォルダ内にxlsデータがあるか有無チェック
With Application.FileSearch
.NewSearch
.Filename = "*.xls" '”ABC*.xls"なども可能
.FileType = msoFileTypeAllFiles
.LookIn = TargetFolder.items.Item.Path '指定フォルダ
.SearchSubFolders = False
.Execute '検索実行
'検索結果が0の場合終了
If .FoundFiles.Count = 0 Then
MsgBox "選択したフォルダの中にはxlsデータはありません。"
Exit Sub
End If
End With
'保存するディレクトリを決める
Set SaveFolder = ShellApp.BrowseForFolder(0, "保存先フォルダを選択してください。", 1)
If SaveFolder Is Nothing Then Exit Sub
'処理を行うディレクトリ
strDir = TargetFolder.items.Item.Path
strDir2 = SaveFolder.items.Item.Path
'処理を行う対象データ
strFnm = Dir(strDir & "\*.xls")
'警告ウインドウ非表示
Application.ScreenUpdating = False
'処理開始
Do Until strFnm = ""
Set wb = Workbooks.Open(strDir & "\" & strFnm)
'処理内容
ShtCnt = wb.Worksheets.Count
'MsgBox ShtCnt
AWN = Left(wb.Name, Len(wb.Name) - 4)
'MsgBox AWN
i = 1
ChDir (strDir2)
Do
wb.Worksheets(i).Activate
wb.Worksheets(i).Copy
ActiveWorkbook.Close savechanges:=True _
, Filename:=AWN & "_" & ActiveSheet.Name & ".xls"
i = i + 1
'MsgBox "通過確認"
Loop Until i > ShtCnt
wb.Close False
strFnm = Dir() '次のファイル名
Loop
Application.ScreenUpdating = True
MsgBox "分割処理が終了しました。"
End Sub
Sub clear1() '書き出されたリストのクリア
Dim i As Integer
'最終行の数値を代入
i = Sheets("作業シート").UsedRange.Rows.Count + 1
Range("B10:T" & i & " ").Clear
Range("E5").ClearContents
Range("T2:T4").ClearContents
End Sub
Sub clear2() '幅調整のクリア
Range("F2").ClearContents
End Sub
Sub clear3() 'ページ設定シートのクリア
Range("H4:J4").ClearContents
End Sub
Private Sub check()
Dim i As Integer
Dim j As Integer
Dim page_num As Integer
Dim haba_num As Integer
page_num = 0
haba_num = 0
For i = 1 To num
'処理前ステータスと処理後ステータスの比較(ページ設定部分)
For j = 1 To 7
If Cells(i + 9, j + 3).Value <> Cells(i + 9, j + 10).Value Then
Cells(i + 9, j + 3).Interior.ColorIndex = 39
If Cells(i + 9, 19).Value <> 1 Then
Cells(i + 9, 19).Value = 1
page_num = page_num + 1
End If
End If
Next j
'幅設定したかの有無
If Cells(i + 9, 18) <> "" Then
Cells(i + 9, 20).Value = 1
haba_num = haba_num + 1
End If
Next i
Range("T3").Value = page_num
Range("T4").Value = haba_num
End Sub
