エクセルのページをシートごとに自動分割するやり方について(列、行ともに同一に)

エクセルのマクロについての質問です。
ページ数が100ページ以上あるデータを改ページごとシートに分けたいです。
一つ一つのページの行数は違います。
色々と検索していたら
↓↓↓↓↓↓↓↓↓↓

Sub 表をシートに分割()
　Dim V_Page As Integer, H_Page As Integer
　Dim V As Integer, H As Integer
　Dim Top As Integer, Left As Integer
　Dim Bottom As Integer, Right As Integer
　Dim NewWS As Worksheet
　Dim P_Area As Range
　With Worksheets("Sheet1") '元の表があるシート名を指定
　　H_Page = .HPageBreaks.Count + 1 '行方向のページ数
　　V_Page = .VPageBreaks.Count + 1 '列方向のページ数
　　Set P_Area = .Range(.PageSetup.PrintArea) '印刷範囲を取得
　　For V = 1 To V_Page '列方向のループ
　　　For H = 1 To H_Page '行方向のループ
　　　　'コピーする表の左上の行番号を取得
　　　　If H = 1 Then
　　　　　Top = P_Area.Cells(1).Row
　　　　Else
　　　　　Top = .HPageBreaks(H - 1).Location.Row
　　　　End If
　　　　
　　　　'コピーする表の左上の列番号を取得
　　　　If V = 1 Then
　　　　　Left = P_Area.Cells(1).Column
　　　　Else
　　　　　Left = .VPageBreaks(V - 1).Location.Column
　　　　End If
　　　　
　　　　'コピーする表の右下の行番号を取得
　　　　If H < H_Page Then
　　　　　Bottom = .HPageBreaks(H).Location.Row - 1
　　　　Else
　　　　　Bottom = P_Area.Cells(P_Area.Cells.Count).Row
　　　　End If
　　　　
　　　　'コピーする表の右下の列番号を取得
　　　　If V < V_Page Then
　　　　　Right = .VPageBreaks(V).Location.Column - 1
　　　　Else
　　　　　Right = P_Area.Cells(P_Area.Cells.Count).Column
　　　　End If
　　　　
　　　　'シートを一番後ろに追加
　　　　Set NewWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
　　　　NewWS.Name = "表" & (V - 1) * H_Page + H '表の名前をつける
　　　　　
　　　　'表を追加したシートにコピー
　　　　.Range(.Cells(Top, Left), .Cells(Bottom, Right)).Copy NewWS.Cells(1, 1)
　　　Next
　　Next
　End With
End Sub

このコードがやりたいことに最も近かったのですが、
列の幅がコピー元と同じにならず、テキストボックスが変に伸びてしまったり、ページ自体の横幅が変わってしまいました。
このコードのどこをどのように変更すれば上記のようにページを分割することができるでしょうか？
ご教授お願いいたします。

質問者からの補足コメント

• よく確認したところ、画像自体の大きさが変わっているのではなくて、行の高さが元シートから変更されてしまっていて、それに付随して画像の縮尺が変わるなどの問題が起きているようでした。

  No.1の回答に寄せられた補足コメントです。 補足日時：2020/05/01 10:23

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2020/04/30 15:03

＞列の幅がコピー元と同じにならず、テキストボックスが変に伸びてしまったり、ページ自体の横幅が変わってしまいました。

お好みに合うか分かりませんが、個別で設定する方法です。一度にコピペも出来るかもしれませんが、取敢えず、、
列幅です。。

該当箇所
'表を追加したシートにコピー

.Range(.Cells(Top, Left), .Cells(Bottom, Right)).Copy NewWS.Cells(1, 1)

For i = 1 To Right
NewWS.Columns(i).ColumnWidth = .Columns(i).ColumnWidth
Next

Dim i As Long　などで i を変数宣言してください。

この回答へのお礼

ありがとうございます！
列幅共にうまくいきました！
しかし、画像の大きさや位置が微妙に元データとずれてしまっていました。
これはセルにコピーをしているからでしょうか？
例えば、列幅が元シートと全く同じシートをページ分用意して、そのシートのA1にセルを挿入するというような動作はできますでしょうか？

お礼日時：2020/05/01 09:13

No.5 回答者： Qchan1962 回答日時： 2020/05/01 11:05

＃４補足

行単位のコピーは、ページエリア外のデータもコピーされてしまいますので
仕様に合わないかも知れません。。

No.4 回答者： Qchan1962 回答日時： 2020/05/01 11:01

補足を読みました。

方法は、大きくプロセスを変えない場合、2つ考えられます。
1つは＃２の方法（＃３で修正）を試してみる
2つ目は、＃1の方法で、行単位のコピペをする。

.Rows(Top & ":" & Bottom).Copy NewWS.Rows(1)

参考まで

この回答へのお礼

ご返信ありがとうございました！
うまくいきました！

お礼日時：2020/05/01 12:17

No.3 回答者： Qchan1962 回答日時： 2020/05/01 10:44

#1

>しかし、画像の大きさや位置が微妙に元データとずれてしまっていました。
先にコピーしてから列幅設定しているせいかもしれません。
検証していませんので、、見落としですね。すみません。

新しいシートを作る
　　　　Set NewWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
　　　　NewWS.Name = "表" & (V - 1) * H_Page + H '表の名前をつける
先に
For i = 1 To Right
NewWS.Columns(i).ColumnWidth = .Columns(i).ColumnWidth
Next
を実行して
.Range(.Cells(Top, Left), .Cells(Bottom, Right)).Copy NewWS.Cells(1, 1)
上手く行きますでしょうか。

＃２
shapeを見落としていました。
コピー先のShapeを削除する必要がありますね。
Dim shp As Shape

Set NewWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
NewWS.Name = "表" & (V - 1) * H_Page + H '表の名前をつける

.Cells.Copy NewWS.Cells(1,1)
NewWS.Cells.ClearContents
For Each shp In NewWS.Shapes
shp.Delete
Next shp
　　　　'表を追加したシートにコピー
　　　　.Range(.Cells(Top, Left), .Cells(Bottom, Right)).Copy NewWS.Cells(1, 1)

>例えば、列幅が元シートと全く同じシートをページ分用意して、そのシートのA1にセルを挿入するというような動作はできますでしょうか？
可能ですが、全体のプロセスを見直す必要がありますね。

今回の回答は、ご掲示のプロセスがありましたので、それに基ずくアドバイスになります。

参考まで

この回答へのお礼

お早いご返信ありがとうございます！
書き直してみました。
これで大丈夫でしょうか？
実行したところ「実行時エラー'1004'　この操作は結合したセルには行えません」とメッセージが出てしまいました。7/60シートほどはうまくいっていました！！
デバックの結果「.Range(.Cells(Top, Left), .Cells(Bottom, Right)).Copy NewWS.Cells(1, 1)」この行が黄色く表示されました。
ご回答よろしくお願いします。

Dim i As Long
　Dim shp As Shape

'シートを一番後ろに追加
Set NewWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
NewWS.Name = "表" & (V - 1) * H_Page + H '表の名前をつける

For i = 1 To Right
NewWS.Columns(i).ColumnWidth = .Columns(i).ColumnWidth
Next

.Cells.Copy NewWS.Cells(1,1)
NewWS.Cells.ClearContents
For Each shp In NewWS.Shapes
shp.Delete
Next shp

'表を追加したシートにコピー
.Range(.Cells(Top, Left), .Cells(Bottom, Right)).Copy NewWS.Cells(1, 1)

Next
Next
End With
End Sub

お礼日時：2020/05/01 11:32

No.2 回答者： Qchan1962 回答日時： 2020/04/30 15:18

行、列共になら、こんな方法も、、

.Cells.Copy NewWS.Cells
NewWS.Cells.ClearContents

'表を追加したシートにコピー
.Range(.Cells(Top, Left), .Cells(Bottom, Right)).Copy NewWS.Cells(1, 1)

この回答へのお礼

ご回答ありがとうございました。
私のやり方が悪いのかもしれませんが、コピーされる範囲がうまく指定できず演算もエラーで途中でとまってしまいました...
申し訳ありません。

お礼日時：2020/05/01 09:13