VBAでぺージ設定を継承するファイル分割の方法

質問

エクセルファイルの分割方法について教えてください。

使用OS等：Windows XP、Excel2003

具体的には1ブック、1シートのみに全データが入っています。

項目行は2行あり、分割のキーと項目がA列に入っています。
そのキー毎に新しいファイルを作りたいと考えています。

始めに新しいファイルにパスワードをつけるかどうか、つけるならつけたいパスワードを入力するようなフォームが立ち上がります。
そして、分割したい元ファイルはどれなのか選択式になっており、いろいろなファイルに適応できるような物にしています。
尚、元ファイルの入っているフォルダ内に分割された各々のファイルを作成します。

分割後のファイルには、”キー（XXX)+元ファイル名”にし、ページ設定や書式なども継承するようにしたいのですが、今使っているものですと、ページ設定が繁栄されません。

ほとんど初心者なもので、元々あったマクロを少し修正したりはしているのですが、上記の問題を解決する事ができず、困っております。

使用中のコードを載せますので、アドバイスまたは違う方法がありましたら、ご教示願います。
コメントなどつけていただけるとありがたいと思います。

どうぞよろしくお願い致します。

Sub 分割パスあり()
Dim DPath As String
Dim DName As String
Dim fNAME As String
Dim fiNAME As String
Dim pass As String
Dim oneNAME As String
Dim oneFILE As String
Dim opdia
Dim n

UserForm1.Hide
pass = InputBox("パスワードを入力して下さい。", "パスワード入力")
opdia = Application.Dialogs(xlDialogOpen).Show
If opdia = Cancel Then
Exit Sub
End If
DPath = ActiveWorkbook.Path & "\"
DName = ActiveWorkbook.Name

Range("A:A") = Range("A:A").Value
Range("A3").Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess
Selection.EntireRow.Insert shift:=xlShiftDown
n = 4
For n = 4 To ActiveCell.CurrentRegion.Rows.Count * 2
On Error GoTo ErrorHandler
If Cells(n, 1).Value = Cells(n - 1, 1).Value Then
Else
fNAME = Cells(n - 1, 1).Text
fiNAME = fNAME & DName

Rows("1:2").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass
Windows(DName).Activate

Cells(n, 1).EntireRow.Insert shift:=xlShiftDown
Cells(n - 1, 1).CurrentRegion.EntireRow.Select
Selection.Copy
Windows(fiNAME).Activate
ActiveSheet.Paste Destination:=Range("A3")
Cells.Columns.AutoFit

ActiveWorkbook.Close savechanges:=True
Windows(DName).Activate
n = n + 1
End If
Next

oneNAME = Cells(n, 1).Text
oneFILE = oneNAME & DName

FileCopy Source:=fiNAME, Destination:=oneFILE
Rows("1:2").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=DPath & oneFILE, password:=pass
Windows(DName).Activate

Cells(n, 1).CurrentRegion.EntireRow.Select
Selection.Copy
Windows(oneFILE).Activate
ActiveSheet.Paste Destination:=Range("A3")
Cells.Columns.AutoFit

ActiveWorkbook.Close savechanges:=True

Application.CutCopyMode = False
Application.DisplayAlerts = False
Windows(DName).Close savechanges:=False
MsgBox "分割処理が終了しました"

Exit Sub
ErrorHandler:
ActiveWorkbook.Close savechanges:=False
Windows(DName).Close savechanges:=False
MsgBox "分割処理が終了しました"
Exit Sub
End Sub

回答No.3

ap_2

僕のミスです。確認してないのバレましたね（苦笑）

'---> 変更後
　'元シートを新しいブックとして複製
　ActiveSheet.Copy
　ActiveSheet.Cells.Clear
　ActiveSheet.Range("A1").Select　'★A1を選択
　'新しいブックを保存
　ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass
　'1,2行目をコピペ
　WorkBooks(DName).Activate
　ActiveSheet.Rows("1:2").Copy
　WorkBooks(fiNAME).Activate
　ActiveSheet.Paste
　WorkBooks(DName).Activate
'<---

★の1行が必要です。「新しいブックを開く」から「シートコピー＞"新しいブック"」の操作に置き換えました。2箇所とも差し替えちゃってください。印刷設定をコピーした以外はほぼ同じですが、複製したブックにはシートがひとつしかないので、必要に応じてSheets.Addを。

あと、ANo.1のはエラーになります。エラー発生時に正常っぽく終了しちゃうのは混乱を招くので、変えておくとよさそうです（※On Error GoTo ErrorHandlerで、エラーダイアログを出さず "ErrorHandler:" のラベルまで処理を飛ばしてます）

＠後から3行目
　MsgBox "分割処理に失敗しました"

VBEでは、F8キーで（メニュー＞デバッグでも）コードを１行ずつ実行できます。ローカルウィンドウを開いておけば、変数の中身も覗けちゃいます。便利ですし、理解の助けにもなるので、試しに使ってみてください。

ちなみに、質問文はそんなもんだと思いますよ（笑）。要領よく聞けるなら解決できるでしょうし、足りない部分はコードが補ってくれます。こーいうトコにあがるコードは読み辛いのも当たり前ですが、全部読むワケじゃないので。
ええ、だから失敗するんですが…今度は動くかな（－－；

お礼

ap2様、体調不良のためお休みしていたので、お礼が遅くなってしまい、大変申し訳ございません。
再度、ご回答くださり本当にありがとうございました。

早速、試してみようと思います。
ご丁寧なフォロー、感謝致します。本当に嬉しいです！

回答No.2

imogasi

コード例が長くて、質問の意図が判りにくい。
「継承」などと難しい言葉を使っているが、プログラムのプロですか。
ーーー
質問は、エクセルシートをコピーしたとき、コピーで出来た（コピーされた）シートに、ページ設定の設定を効き告ぎたい引継ぎたい。それも、ＶＢＡコードでということですか。
シートをコピーしても、コピー元のページ設定項目は引き継がれないようだ。
シートのセルの値や、書式や、コメント、入力規則、数式など以外のものは、移らないようだ。
何か１行（２－３行）で別シートのＰａｇｅＳｅｔＵｐの項目（多数あり）を代入するような方法はＰａｇｅＳｅｔＵｐオブジェクトにはないようだ。
だから設定可能項目は、ページ設定のマクロの記録で判るので、そのそれぞれの項目に対し
ＢシートＰａｇｅＳｅｔＵｐ項目＝ＡシートＰａｇｅＳｅｔＵｐ項目（内容は値（数値・文字列・Ｆａｌｓeなど）でしょう）
を項目ごとに繰返さないとならないようだ。
ーー
シート数が多いとコピーの時間がかかるという質問
http://www.keep-on.com/excelyou/2000lng4/200005/00050060.txt
２０１０で変化があったようだ
http://kinuasa.wordpress.com/category/office%E9%96%A2%E9%80%A3/
同様の質問？
http://okwave.jp/qa/q6273710.html
ーー
もし上記のような質問なら質問のコード例など無関係では。

お礼

imogasi様　お返事遅くなり申し訳ありません。
長いコードの貼り付けや、継承などという言葉を使ってしまい、気分を害してしまったら
大変申し訳ありません。
私はプロどころか、本当にマクロを勉強し始めたばかりの素人同然で、既存で使ってあったものを
修正して作れるのなら・・・との思いで質問させていただきました。

どうやらちょっとした修正だけという訳にはいかないようですね・・・。

上記提示していただいた同様の質問などを参考に考えたいと思います。

回答No.1

ap_2

セルのコピーを繰り返して処理しているようですが、ページ設定(印刷関係)はシートの情報なので、セルのコピーでは写すことができません。今回は目的が複製っぽいので、新しいファイルを生成する際に、シートをコピーして作るのが良さそうです。

試しに書いてみました。動くか分りませんが…

'---> 変更前
' Rows("1:2").Copy
' Workbooks.Add
' ActiveSheet.Paste
' ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass
' Windows(DName).Activate
'<---

'---> 変更後
　'元シートを新しいブックとして複製
　ActiveSheet.Copy
　ActiveSheet.Cells.Clear
　'新しいブックを保存
　ActiveWorkbook.SaveAs Filename:=DPath & fiNAME, password:=pass
　'1,2行目をコピペ
　WorkBooks(DName).Activate
　ActiveSheet.Rows("1:2").Copy
　WorkBooks(fiNAME).Activate
　ActiveSheet.Paste
　WorkBooks(DName).Activate
'<---

Sheets.Copyは、挿入位置を指定しなければ、そのシートひとつだけの「新しいブック」を生成します。セルのデータごと複製されるので、Cells.Clearで一旦まっさらにします。これで、ページ設定を引き継ぎながら、WorkBooks.Addと同じことができます。

ちなみに、ページ設定のプロパティをひとつずつ反映することもできますが、大変かと。参考程度に↓(※この中にプロパティがイッパイ入ってるよ！)
　Sheets.PageSetup がページ設定
　Sheets.HPageBreaks が改ページ

初心者とのことですが、記録機能でここまで作ったのか、他の人が作ったのか…、前者なら最初の数行で足りたかも知れませんね。余談ですが、慣れてきたら、Activateをやめると処理がすっきりしますよ。Workbooks("hoge.xls").Sheets("hoge").Copy のようにすれば、ActiveSheetを対象にしなくてもよくなるので。

お礼

ap2 様、お返事送れて大変申し訳ありません。
ご丁寧にご回答いただきありがとうございました。

試しに教えていただいたコードに書き換えてみましたが、1つだけ全く空っぽのファイルが
作成されただけ・・・という結果になってしまいました。

2箇所同じ箇所があって、2箇所とも変えてしまったのがわるかったのでしょうか・・・？

しかしながら、ActiveSheetの件など、参考になりました。
どうもありがとうございました。