マコテキ-些細な日記

昨日張ったソースに修正点が見つかった＾＾；
追加したのは印刷する枚数が1枚だった時は処理を行わない。

あと処理対象のデータが何枚の印刷枚数データなのかを表示するために2列目に現れるように更に追加
それとシート名も変えないといけなかったんだわ＾＾；　コピペして警告で気付いた。盲点だった(´・ω・`)

やっとこさ私が追い求めていたものが完成しましたＹＯ！
因みに完成したツールの使用後画面






これを元に会社で組み立てねばいかんな＾＾；
セルの位置は気をつけないと動作してくれないからね・・・。

・・・ふと気付くと11月も後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
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
   
    'このツールの情報を取得
    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
   
    '保存するディレクトリを決める
    Set SaveFolder = ShellApp.BrowseForFolder(0, "保存先フォルダを選択してください。", 1)
    If SaveFolder Is Nothing Then Exit Sub
   
    '処理を行うディレクトリ
    strDir = TargetFolder.items.Item.Path
    strDir2 = SaveFolder.items.Item.Path
   
    'ツールの一覧シートにター別途フォルダの場所を記入
    Cells(2, 3).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 + 6, 3).Value = wb.Name
        Call para_in(wb)
        Call page_status(i + 6, 4)

        'ページ設定を変更する
        wb.Activate
        Call page_status_change
        '処理後のステータスを書き留める
        toolwb.Activate
        Call para_in(wb)
        Call page_status(i + 6, 11)
       
        '処理を行ったデータを保存する
        wb.Activate
        ActiveWorkbook.Close savechanges:=True _
        , Filename:=AWN & "_" & "pageset" & ".xls"
       
        i = i + 1

        strFnm = Dir()                   '次のファイル名
    Loop
    Application.ScreenUpdating = True

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 '同じく縦幅設定
    .PrintTitleRows = "$1:$7" '行タイトルの設定

    '.PrintArea = "" '印刷領域の設定
    '.PrintTitleColumns = "" '列タイトルの設定
    End With
End Sub





 

とりあえず求めている最低限の処理を行ってくれるマクロの完成～
しかしまだ追加せねばいかん処理がまだあるんだよね＾＾；　とりあえず今回はココまで
画像の３～６行目は事前に入力しないとダメなんで入力しておくこと。

結構悩み、苦しみましたが自分が望んでいるVBAが完成しましたZE
以下VBAソース

Sub SheetCopy3() 'ユーザーが指定したディレクトリ内にある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
   
    '保存するディレクトリを決める
    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

End Sub
__________________________
作ってて楽しかったわ＾＾

参考になったページは前の日記で紹介したもの＾＾
結構試行錯誤もしたし、エラーがでない不具合とかもでて苦しんだわ(￣Д￣;;
しまし不屈の闘士と発想の勝利とでも言うべきか。完成するとかなり嬉しいわｗ

後はこちらを色々と利用するまでですわ。偶然このページを見つけた方もコピペしてもらってかまわないけど自己責任で。


さて、これでもまだひとつ出来ただけにすぎないからね。
後思ってるマクロもあるけどそれは明日にしますかね～。

それらのツールとも連携できるようなソースの書き方にせねばいかんな。