よく読まれている記事一覧 | 在宅仕事日記

【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

在宅仕事日記

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

邪魔なリサーチ機能