在宅仕事日記

【Excel VBA】ページ毎に別ファイルで保存するマクロ

Excelでページ毎にファイルを分ける必要があったので、作成したマクロです。最初は、新しいブックファイルにページ毎に行を選択して、コピー＆ペーストするコードを考えていたのですが、ページ設定はコピーできませんでした。後でページ設定を元のファイルに合わせるコードを追加しても、完全に同じにはならなかったのです。（ページ内に全て収まらないなど、違いがありました）Excelの一般機能の「移動またはシート」で、シートごと新たなブックにコピーすることは可能です。この機能を使用して、後で不要な行を削除すると、やりたいことはできます。ですが、同じことをマクロでやろうとしても、うまくいきませんでした。結局、シートのコピーは諦めて、コピーファイルとして保存して、不要な行を削除する方法で上手く動作しました。Sub ページ毎に別ファイルで保存()    Dim targetWb As Workbook    Set targetWb = Workbooks("一括")        Dim i As Long    Dim st As Worksheet    Dim pgWb As Workbook    Dim newBk As Workbook    Dim PgLastRw As Long    Dim ct As Long    ct = 1        Dim StLastRw As Long    Dim StartRw As Long    Dim c As Long    Dim mySheet As Worksheet        For c = 1 To targetWb.Sheets.count    '下記のコードの「st.Range(」の後の"A"は、ファイルによって書き換える    'シートの最終行を取得するためのコード        StLastRw = targetWb.Sheets(c).Range("A" & Rows.count).End(xlUp).Row        For i = 1 To targetWb.Sheets(c).HPageBreaks.count + 1    '"C:\MacroTest\"を保存したい場所に変更する。           targetWb.SaveCopyAs Filename:= _                    "C:\MacroTest\" & targetWb.Sheets(c).Name & "_P " & i & ".xlsx"                        Set pgWb = Workbooks.Open("C:\MacroTest\" & targetWb.Sheets(c).Name & "_P " & i & ".xlsx")                Select Case i                    Case 1                        pgWb.Sheets(c).Activate                        PgLastRw = targetWb.Sheets(c).HPageBreaks(i).Location.Row                        pgWb.Sheets(c).Rows(PgLastRw & ":" & StLastRw).Delete                                                ActiveSheet.Move Worksheets(1)                        Application.DisplayAlerts = False                        For Each mySheet In Worksheets                            If mySheet.Name <> ActiveSheet.Name Then                                mySheet.Delete                            End If                        Next                        Range("A1").Select                        ActiveWorkbook.Save                        Application.DisplayAlerts = True                                                ActiveWorkbook.Close                                            Case 1 To targetWb.Sheets(c).HPageBreaks.count                        PgLastRw = targetWb.Sheets(c).HPageBreaks(i).Location.Row                        pgWb.Sheets(c).Activate                        pgWb.Sheets(c).Rows(PgLastRw & ":" & StLastRw).Select                        pgWb.Sheets(c).Rows(PgLastRw & ":" & StLastRw).Delete                        PgLastRw = targetWb.Sheets(c).HPageBreaks(i - 1).Location.Row                        pgWb.Sheets(c).Rows("1:" & PgLastRw - 1).Select                        pgWb.Sheets(c).Rows("1:" & PgLastRw - 1).Delete                                                ActiveSheet.Move Worksheets(1)                        Application.DisplayAlerts = False                        For Each mySheet In Worksheets                            If mySheet.Name <> ActiveSheet.Name Then                                mySheet.Delete                            End If                        Next                        Range("A1").Select                        ActiveWorkbook.Save                        Application.DisplayAlerts = True                                                ActiveWorkbook.Close                    Case Else                        PgLastRw = targetWb.Sheets(c).HPageBreaks(i - 1).Location.Row                        pgWb.Sheets(c).Activate                        pgWb.Sheets(c).Rows("1:" & PgLastRw - 1).Delete                                                ActiveSheet.Move Worksheets(1)                        Application.DisplayAlerts = False                        For Each mySheet In Worksheets                            If mySheet.Name <> ActiveSheet.Name Then                                mySheet.Delete                            End If                        Next                        Range("A1").Select                        ActiveWorkbook.Save                        Application.DisplayAlerts = True                                                ActiveWorkbook.Close                               End Select                 Next        NextEnd Sub