ＶＢＡで貼り付けがうまくいかない

質問

windowsXP　　Ｅｘｃｅｌ2000でＶＢＡマクロ完成しました。
Ａ4用紙１枚のシートの上半分は請求書、下半分は領収書で、領収書は請求書の値を、すべてをリンクさせています。これを１０枚のシート（１０人分）に作成しました。
この請求書と領収書を別々に印刷用シート１枚に貼り付け一括印刷をします。つまり、１０枚のシートの上半分を一括で印刷するのです。
印刷用シートの貼り付け位置は以下のようになり

１枚目上　　3枚目上　5枚目上　7枚目上　9枚目上
２枚目上　　4枚目上　6枚目上　8枚目上　10枚目上

請求書、領収書はそれぞれ５枚印刷すればいいのです。
ところがうまく貼り付け位置が設定できず前のページの一部が
次のページに少しずれて表れみっともない請求書になってしまいます。
なんとかきちっと印刷したいのですが困っています。お助けください。

回答No.4

Wendy02 · ベストアンサー

こんにちは。Wendy02です。

何度も繰り返し実験してみましたが、確かに、ずれるのは分るのですが、マクロ自体の問題ではありませんね。問題は、正しい印刷領域の設定がされているか、どうかっていうことだと思いました。そのズレをマクロで修正するものも作ってみましたから、ものすごく時間が掛かるので、やむを得ないのですが、以下の検査用のプログラムを作ってみました。

なお、おまけとして、画像貼り付け用のプログラムを私も作ってみました。

'-----------------------------------------------------
Sub PrintAreaChecking()
'水平改行位置検査プログラム
　 Dim Pbks() As Variant
　 Dim k As Long
　 Dim Hcnt As Long '水平改行数
　 Dim i As Long
　 Dim j As Integer
　 Dim t As Long
　 Dim dummy As Variant
　 Dim PctRow() As Variant
　 Dim pct As Object
　 Dim msg
　 Dim flg As Boolean

　 With ActiveSheet
　 k = .Pictures.Count
　 'プリンタ設定
　 If .PageSetup.PrintArea = "" Then
　　　.PageSetup.PrintArea = "$A$1:" & _
　　　.Pictures(k).BottomRightCell.Address
　 End If

　 '検査プログラム
　 ReDim PctRow(1 To k)
　 For Each pct In .Pictures
　　　i = i + 1
　　　PctRow(i) = pct.TopLeftCell.Row
　 Next pct

　　 Hcnt = ExecuteExcel4Macro("COLUMNS(GET.DOCUMENT(64))")

　 ReDim Pbks(1 To Hcnt)

　 For j = 1 To Hcnt
　　　t = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64),1," & j & ")")
　　　dummy = Application.Match(t, PctRow, 0)
　　　If IsError(dummy) And j <> Hcnt Then
　　　　 Pbks(j) = t & " *"
　　　　 flg = True
　　　　 Else
　　　　 Pbks(j) = t
　　　End If
　 Next j
　 If flg Then
　　 msg = "行数が現在は、 " & Val(Pbks(1))
　　 msg = msg & "です。" & vbCrLf & "プレビュー画面で、マージンを調整して設定しなおしてください。"
　 Else
　　 msg = "設定は、問題ありません。ズレは出ないはずです。"
　 End If
　　 MsgBox "水平改行位置" & vbCrLf & Join(Pbks, vbCrLf) & vbCrLf & msg
　　 If flg Then
　　　 .PrintPreview
　　 End If
　End With
End Sub

'======================================================
'おまけ
'領収印刷 (2) に貼り付けるために、Wendy02が作ってみたもの
'単に参考まで。
'======================================================
Sub PastePictures()
Dim RyoshuSh As Worksheet
Dim sh As Worksheet
Dim i As Long 'カウンタ
Dim j As Long '行
Dim k As Integer '列

Set RyoshuSh = Worksheets("領収印刷 (2)")
'最初に画像を削除
RyoshuSh.Pictures.Delete

'セルの初期値
k = 1: j = 1
Application.ScreenUpdating = False
For Each sh In Worksheets
　If sh.Name Like "[A-Z]*" Then
　 sh.Activate

　 sh.Range("B34:AB65").CopyPicture xlPrinter, xlPicture

　 sh.Range("B3").Select

　 Application.Goto RyoshuSh.Cells((j - 1) * 34 + 1, (k - 1) * 29 + 1)
　 RyoshuSh.Pictures.Paste

　 '行列:カウンタ
　 i = i + 1
　 If (i Mod 2) = 0 Then j = j + 1　'行
　 k = (i Mod 2) + 1　　'列
　End If
Next

Application.ScreenUpdating = True
Beep
Sheets("hyousi").Select
End Sub

補足

Wendy02様　素晴らしいプログラム作っていただきありがとうございました。
水平改行位置検査プログラムは、時間はかからず、瞬間的に次の表示がでました。
「水平改行位置　63　設定は問題ありません。ズレはでないはずです。」ＯＫして
プレビュを見るとやはり４枚目のみ、ずれていました。こんなすごいプログラムでも
修正できないなんて不思議です。
おまけの'領収印刷 (2) に貼り付け用のプログラムですが
For Each sh In Worksheets
　If sh.Name Like "[A-Z]*" Then
　 sh.Activate
ここの部分--特に"[A-Z]*が私の力では理解できません。次のようなコードでしたら
何とか理解できます。どうか超初心者の私を助けてください。

Sub 領収書作成部品()
　請求書セルに数式や文字列を入れる。
End Sub

Sub 請求書入力()
Application.ScreenUpdating = False
Dim list, SheetName
list = Array("ＡＡ", "ＢＢ", "ＣＣ", "ＤＤ", "ＥＥ", "ＦＦ", "ＧＧ", "ＨＨ", "ＩＩ", "ＪＪ")

For Each SheetName In list
Sheets(SheetName).Activate
Call 領収書作成部品
Next
Sheets("ｈｙｏｕｓｉ").Select
End Sub

回答No.6

Wendy02

こんにちは。

＞ところが、４ページ目のところだけ左の縦線が実践になっています。これを破線にすれば、すべて解決できそうです。ところがどうやっても破線にできません。なんででしょうか。

朝から、ずっと考えていたけれど、なるほど!　私も、うかつでしたね。（^^;
そのことは、ふと、頭の中でよぎったのですが、それは手抜きして無視したのがいけませんでした。

「領収印刷 (2)」シートでは、直すことは出来ませんから、コピー元から直さないといけませんね。「コピー元のシートの列の幅」が違っているものがあります。

別の言い方をすれば、その貼り付ける元のシートの範囲の画像の大きさがずれているということですね。

右マージン・左マージンで収納できれば、いまのままでよいのですが、やはり元を直したほうがよいですね。

****
＞ここの部分--特に"[A-Z]*が私の力では理解できません。次のようなコードでしたら何とか理解できます。どうか超初心者の私を助けてください。

[A-Z]* :意味は、最低でも、A～Z までの文字が先頭にあるというだけの意味です。
もしも、[A-Z][A-Z]*　なら、最低でも、A～Z までの文字が２つあるという意味です。

*は、何か、0個以上の文字があるという意味です。
[　] は、例えば、0-9 なら、0 ～ 9 までということです。

＞Sub 請求書入力()
＞Application.ScreenUpdating = False
＞Dim list, SheetName

別に、それでよいです。こちら側では、一体、いくつまであるか分らないので、たぶん、[A-Z]*　にしておけば問題ないだろうと考えただけです。

回答No.5

Wendy02

文章の修正加筆

×　そのズレをマクロで修正するものも作ってみましたから、ものすごく時間が掛かるので、

○　そのズレをマクロで修正するしようと作ってみましたが、印刷設定値を呼び出し設定するのに、ものすごく時間が掛かるので、印刷プレビューで、ご自身の手で修正していただくものとして、

お礼

長期不在の為失礼しました。いろいろありがとうございました。

補足

ご指摘のとおり手動で修正しようと印刷プレビュを見ると、問題の４ページ目のところがおかしいのです。他の正常に印刷されるページのところは、両サイドの縦線がすべて破線になっています。
ところが、４ページ目のところだけ左の縦線が実践になっています。これを破線にすれば、すべて解決できそうです。ところがどうやっても破線にできません。なんででしょうか。

回答No.3

Wendy02

こんにちは。

Wendy02です。

＞それで私いろいろ研究し、領収書の部分を画像として貼り付けることにしたのです。
この方法は、以前、マクロでやったことがあります。ちょっと面倒な作業が必要だったような気がします。

でも、以下の情報だけだと、ちょっと厳しいですね。

＞印刷用シートの貼り付け位置は以下のようになり

＞１枚目上　　3枚目上　5枚目上　7枚目上　9枚目上
＞２枚目上　　4枚目上　6枚目上　8枚目上　10枚目上

これが、1ページに収まるということですか？

それぞれの範囲は、A1:?32 だったのでしょうか？
この辺りが、曖昧になってしまっています。何をどう組み合わせて、1ページにするようにするか、教えてください。

補足

以下のコードで何とか印刷しています。これではだめでしょうか？
Sheets("領収印刷 (2)").Select
Dim 対象シート As Object '変数「対象シート」はオブジェクト型
Set 対象シート = ActiveSheet 'オブジェクトへの参照を変数に代入する
対象シート.Shapes.SelectAll 'すべての図形を選択する
Selection.Delete '現在選択されているオブジェクトを削除する

Sheets("AAA").Select
Range("B34:AB65").Select
Selection.Copy
'ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("領収印刷 (2)").Select
Range("Ａ1").Activate
ActiveSheet.Pictures.Paste
Sheets("AAA").Select
Application.CutCopyMode = False 'コピーの解除
Range("B3").Select

Sheets("BBB").Select
Range("B34:AB65").Select
Selection.Copy
Sheets("領収印刷 (2)").Select
Range("A35").Select
ActiveSheet.Pictures.Paste
Sheets("BBB").Select
Application.CutCopyMode = False 'コピーの解除
Range("B3").Select

Sheets("CCC").Select
Range("B34:AB65").Select
Selection.Copy
Sheets("領収印刷 (2)").Select
Range("AD1").Select
ActiveSheet.Pictures.Paste
Sheets("CCC").Select
Application.CutCopyMode = False 'コピーの解除
Range("B3").Select

Sheets("DDD").Select
Range("B34:AB65").Select
Selection.Copy
Sheets("領収印刷 (2)").Select
Range("AD35").Select
ActiveSheet.Pictures.Paste
Sheets("DDD").Select
Application.CutCopyMode = False 'コピーの解除
Range("B3").Select

以下続く

'ActiveWindow.SelectedSheets.PrintOut
Sheets("hyousi").Select

'ActiveSheet.Protect
End Sub

回答No.2

Wendy02

追伸:

確か、行の高さを狭めて調整することで、64行を入れていたような気がします。

回答No.1

Wendy02

こんにちは。Wendy02です。

うまく行っていないのですね。昨年の11月だったので、だいぶ内容を忘れてしまいました。私のマクロは、まだお使いになっていますか？もしそうですと、前のところから話を遡らないといけないので、ちょっとお時間をくださいますか？少しずつ見当してみます。

あれから、行数が変わったのでしょうか？

補足

その節はお世話になりました。実は請求書に関してはあなた様のマクロ使わせていただいていますが、領収書に関しては請求書のデータをリンクしているので上の方法は使えません。それで私いろいろ研究し、領収書の部分を画像として貼り付けることに下のです。縦に貼り付けも考えましたが、書式が変わってしまい手動で修正しないと行の高さがばらばらになる経験上、横に貼り付けることにし、うまく印刷までこぎつけましたが、５枚のうち４枚目だけ前のシートの部分が少し重なってみっともないです。我慢できる程度ですが、受け取る人にあまりいい印象をあたえないかも。どうしてもそれを修正したいです。