印刷後データを変更し、また同じ雛形で印刷を繰返しをマクロで行いたい。

質問

印刷後データを変更し、また同じ雛形で印刷を繰返しをマクロで行いたい。

シート１に印刷用の雛形があります。
セルの指定された10ケ所くらいに手入力後印刷しています。
この10ケ所の入力内容は別ファイルに有りますが
そのファイルは夜間バッチで毎日更新されます。
またそのデータは今日は20行だけど明日は15行とデータ量が日々変わります。

シート２にこのデータファイルを貼り付けて
そのシート２のデータの１行目（A2からJ2）の各値を
シート１の所定の場所に値を貼付しシート１を１枚印刷。
その後シート２の２行目（A3からJ3）のデータを
シート１の所定の場所に値を貼付し印刷。
これをシート２のデータ分（行です）繰り返し
シート２のデータ（行です）がなくなったら
メッセージＢＯＸで「印刷終了」と出て印刷が停止。
というのをシート１に作成したボタン一つで行いたいです。
（シート２の値をシート１に貼付するのはマクロの記録で完成しましました。
　でも駄目です(T_T)当たり前ですがデータ10行の時のマクロ記録では
　データが15行の時11から15行目は無視されます。
　Do　Loop　で対処可能でしょうか？）

なおシート２にデータを貼り付ける時の
データ選択はエクセルの「ファイルを開く」の小画面を表示させて
使用者に選択させたいです。
↓
fName = Application.GetOpenFilename
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
dPath = fso.GetParentFolderName(fName)

１．シート１の「ファイル選択」ボタンを押す。
２．ファイルを選択する。（開くをクリックすると同時にno.3が自動で行われる）
３．シート２に選択ファイルが貼り付き選択されたファイルは閉じる。
４．シート１の「印刷」ボタンを押す。
５．マクロの記録どうりにシート２の２行目の値がシート１に貼り付く
６．シート１が印刷され、シート１の値がクリア。
７．マクロの記録の法則にならってシート２の３行目の値がシート１に貼り付く
８．シート１が印刷され、シート１の値がクリア。
９．シート２のデータがなくなるまで繰り返す。
10．シート２のデータ分だけ印刷したらメッセージが出る。

データを変更して繰り返して印刷の部分が参考書やWEB検索でなかなか見つかりません。
ご教授をお願いします。

回答No.4

merlionXX · ベストアンサー

gx9wx さん、遅くまでおつかれさまでした。
では追加のご質問への回答です。

> 例：D21→D22
> ("B4,E2,D21,E13,G9,B16,G18,D10,C7,G22", ",")
> ↓
> ("B4,E2,D22,E13,G9,B16,G18,D10,C7,G22", ",")
この部分を変更すればいいのであろうと思うのですが

はい、そのとおりですよ。
上記はA列からJ列の連続した行のデータを配列に取り込み、連続しない範囲にB4,E2,D22,E13,G9,B16,G18,D10,C7,G22の順に入力してます。

> A2→シート１のB4
> J2→シート１のD21
> G2→シート１のG18

これは元のデータ範囲が連続していませんね。そうなると一度に取り込めないので、以下のようにセル自体を配列に取り込み、個別に転記することになります。

Sub 印刷02()
　　Dim myRng(1 To 3) '変数宣言
　　Dim cpRng
　　Dim i As Integer
　　With Sheets("Sheet2")
　　　　Set myRng(1) = .Range("A2") 'データ位置設定
　　　　Set myRng(2) = .Range("J2") 'データ位置設定
　　　　Set myRng(3) = .Range("G2") 'データ位置設定
　　End With
　　cpRng = Split("B4,D21,G18", ",") '転記先セル番地を配列に格納
　　With Sheets("Sheet1")
　　　　Do While myRng(1) <> "" 'A列のデータ位置が空白じゃなきゃ
　　　　　　For i = 1 To 3
　　　　　　　　.Range(cpRng(i - 1)).Value = myRng(i) .Value 'セルデータ転記
　　　　　　Next
　　　　　　.PrintOut '印刷
　　　　　　For i = 1 To 3
　　　　　　　　Set myRng(i) = myRng(i).Offset(1) 'データ位置を1行下に設定
　　　　　　Next i
　　　　Loop '繰り返し
　　　　.Range("B4,D21,G18").ClearContents 'クリア
　　End With
　　For i = 1 To 3
　　　　Set myRng(i) = Nothing '後処理
　　Next
　　MsgBox "おわったわよ。", vbInformation, "φ(^o^:)"
End Sub

お礼

ありがとうございました。

Dim myArray, cpRng '変数宣言
Set myRng = Sheets("Sheet2").Range("A2:J2") 'データ位置設定
cpRng = Split("B4,E2,D21,E13,G9,B16,G18,D10,C7,G22", ",") '転記先セル番地を配列に格納
↓
A2:J2はA列からJ列なので
A2,G2,J2とすればいいのかなと
↓
Dim myArray, cpRng '変数宣言
Set myRng = Sheets("Sheet2").Range("A2,G2,J2") 'データ位置設定
cpRng = Split("B4,D21,G18", ",") '転記先セル番地を配列に格納

では駄目なのですね。

-------------------------

それから先ほど補足で質問した、

　.Range(cpRng(i - 1)).Value = myRng(i) .Value 'セルデータ転記

の構文エラーですが

　.Range(cpRng(i - 1)).Value = myRng(i) 'セルデータ転記

としたら動作しましたが、これで合っていますでしょうか？

補足

ご丁寧にありがとうございます。

教えていただいた物をコピペしたのですが
動作確認の前の貼り付けた状態で

.Range(cpRng(i - 1)).Value = myRng(i) .Value 'セルデータ転記

の部分が赤字になり
「構文エラー」と表示されます。

どこを直していいのか検討が付きません。

お手数をおかけします。
よろしくお願いします。

回答No.6

merlionXX

gx9wx さん、Sub 印刷02()見ました。
お書きになったコメント通りですよ。すっかり自分のものにされましたね。
ごくろうさまでした。

お礼

時間をさいていただきありがとうございました。
またいろいろ丁寧にありがとうございました。

回答No.5

merlionXX

> .Range(cpRng(i - 1)).Value = myRng(i) .Value 'セルデータ転記

> の部分が赤字になり
> 「構文エラー」と表示されます。

おや、なぜかmyRng(i)と.Value の間に空白が入ってしまったようです。
.Range(cpRng(i - 1)).Value = myRng(i)　でも大丈夫ですが、正しくは
.Range(cpRng(i - 1)).Value = myRng(i).Value　です。（空白を削除しました）

では、おやすみなさい。

お礼

ありがとうございました。
無事動作しました。
大変助かりました。

ちょっと補足に相談を入れました。
時間があったら見ていただければと思います。

補足

取り込みデータが連続していない場合の記述をありがとうございました。
教えていただいた物を一生懸命解読して、
自分なりのコメントを入れました。

でさらに教えていただいた

> A2→シート１のB4
> J2→シート１のD21
> G2→シート１のG18
に
　シートC2の値をシートB15に貼り付けるのを追加したいと仮定
して以下の記述にして見ました。この考えで正しいでしょうか？
お手数かけます。よろしくお願いします。

・データが３個→４個に増えた。
　To　3　→　To　4　にする
・Set myRngを１個増やす→（４）を追加→（C2）
・cpRng = Splitに転記先のデータを追加→(B15)
--------------------------------
Sub 印刷02()

'2010年10月8日
'シート２の1行目の指定したセルのデータをシート１の指定したセルに
'転記を行いシート１が印刷される。
'印刷後はシート２の2行目の指定したセルのデータをシート１の指定したセルに
'転記してシート１が印刷される。
'シート２にデータが無くなったら停止する。

'↓【データ変更時変更場所】データ数に合わせてToの右の数字を変える事
　Dim myRng(1 To 4) '変数宣言

Dim cpRng '貼付位置をcpRngとする
Dim i As Integer
With Sheets("Sheet2")

'↓【データ変更時変更場所】データの位置の変化や増減はここを変更する
Set myRng(1) = .Range("A2") 'データ位置設定
Set myRng(2) = .Range("J2") 'データ位置設定
Set myRng(3) = .Range("G2") 'データ位置設定
　Set myRng(4) = .Range("C2") 'データ位置設定
End With

'↓【データ変更時変更場所】データ数の増減でここを変更
'↓【転記位置変更時変更場所】データの転記先だけが変更時もここを変更
　cpRng = Split("B4,D21,G18,B15", ",") '転記先セル番地を配列に格納

With Sheets("Sheet1")
Do While myRng(1) <> "" 'A列のデータ位置が空白でなければ

'↓【データ変更時変更場所】データ数に合わせてToの右の数字を変える事
　For i = 1 To 4 'データの数だけ繰り返す

.Range(cpRng(i - 1)).Value = myRng(i).Value 'セルデータ転記
Next
.PrintOut '印刷

'↓【データ変更時変更場所】データ数に合わせてToの右の数字を変える事
　For i = 1 To 4

Set myRng(i) = myRng(i).Offset(1) 'データ位置を1行下に設定
Next i
Loop '繰り返し

'↓【データ変更時変更場所】データ数の増減でここを変更
'↓【転記位置変更時変更場所】データの転記先だけが変更時もここを変更
　.Range("B4,D21,G18,B15").ClearContents 'クリア

End With

'↓【データ変更時変更場所】データ数に合わせてToの右の数字を変える事
　For i = 1 To 4

Set myRng(i) = Nothing '後処理
Next
MsgBox "おわったわよ。", vbInformation, "φ(^o^:)"
End Sub

回答No.3

merlionXX

gx9wxさん、おはようございます。
別に謝らなくていいですよ。
わたしも余計なことを書いてしまいました。
(o。_。)o反省

で、今度のコードで解決しましたか？
コピー＆ペーストではないのでシート１の罫線が消えることはないと思います。

お礼

思ったとうり動きました。
罫線も消えません。どうもありがとうございました。
自分のマクロは廃止して
教えていただいた物をそっくりそのまま使用させていただきます。
助かりました。早速今日の業務から利用させていただき楽になりました。
感謝、感謝です。
お礼も遅れてすいません。

-----------------

丁寧に教えていただきまして恐縮ですが
今後の事を考えて教えていただきたい事があります。

例えば将来、データはそのままで貼付場所だけが変わった場合
例：D21→D22
("B4,E2,D21,E13,G9,B16,G18,D10,C7,G22", ",")
↓
("B4,E2,D22,E13,G9,B16,G18,D10,C7,G22", ",")
この部分を変更すればいいのであろうと思うのですが
（↑間違えていたらすいません。）

データ位置設定が変更された場合は
例えば、
A列からJ列の10個のデータの中でA,C,G列の値だけを貼り付ける場合は
どうすればいいのでしょうか？メンテでの対応は不可能で
記述を一から書き直す方がいいのでしょうか？

シート２のA列からJ列の中で
初回
A2→シート１のB4
J2→シート１のD21
G2→シート１のG18

↓2回目

A3→シート１のB4
J3→シート１のD21
G3→シート１のG18

データがあるまで繰り返す。

教えていただいた記述を参考に自分で作成しましたが
全然駄目でした。昨日は深夜まで挑戦したけど駄目でした。
それでお礼が遅れました。申し訳ありませんでした。
今後もよろしくお願いいたします。

回答No.2

merlionXX

ANo1のmerlionXXです。

わたしもかなりの「ものぐさ」ですが、gx9wxさんもなかな横着者ですね。
コードを質問しておきながら、不備なマクロを貼り付けてわたしに解読させるんですね。
やりかけた回答なので解読して再度回答はしますが、普通ならば、「Sheet2の"A2:J2"以降の連続したデータを、Sheet1の"B4,E2,D21,E13,G9,B16,G18,D10,C7,G22"に順次代入して行きたいのです。」というように言葉で説明することだとは思いませんか？

で、読込んでSheet2にデータを貼り付けたところまではできているのですね？
それでは、印刷のマクロです。
これでいかがでしょう。

Sub 印刷()
　　Dim myArray, cpRng '変数宣言
　　Set myRng = Sheets("Sheet2").Range("A2:J2") 'データ位置設定
　　cpRng = Split("B4,E2,D21,E13,G9,B16,G18,D10,C7,G22", ",") '転記先セル番地を配列に格納

　　With Sheets("Sheet1")
　　　　Do While myRng(1) <> "" 'データ位置が空白じゃなきゃ
　　　　　　myArray = myRng.Value 'データを配列に格納
　　　　　　For i = 1 To 10
　　　　　　　　.Range(cpRng(i - 1)).Value = myArray(1, i) '転記
　　　　　　Next
　　　　　　.PrintOut '印刷
　　　　　　Set myRng = myRng.Offset(1) 'データ位置を1行下に設定
　　　　　　Erase myArray 'データの配列を空に
　　　　Loop
　　　　.Range("B4,E2,D21,E13,G9,B16,G18,D10,C7,G22").ClearContents
　　End With
　　Set myRng = Nothing
　　MsgBox "おわったよ。"
End Sub

お礼

補足の投稿で不愉快な思いをさせてしまい申し訳ありませんでした。
また再度教えてもらった記述の結果報告が遅れてしまい
申し訳ありません。
思ったとうりに動いています。
また罫線も消えません。
本日から利用させていただいて楽になりました。
どうもありがとうございました。

補足

>不備なマクロを貼り付けてわたしに解読させるんですね。

申し訳ありません。そんなつもりではなかったのです。
よく「記述を示さなければ回答ができません。」と注意されるので
貼付ました。

＞普通ならば、
＞「Sheet2の"A2:J2"以降の連続したデータを、
＞Sheet1の"B4,E2,D21,E13,G9,B16,G18,D10,C7,G22"に
＞順次代入して行きたいのです。」というように言葉で説明すること

これは最初の質問で

＞そのシート２のデータの１行目（A2からJ2）の各値を
＞シート１の所定の場所に値を貼付しシート１を１枚印刷。
＞その後シート２の２行目（A3からJ3）のデータを
＞シート１の所定の場所に値を貼付し印刷。

と質問したので補足には記述だけを書いた次第です。

大変申し訳ありません。

回答No.1

merlionXX

肝心の、Sheet2のA~J列のデータをSheet1のどこにもってくるのかがわかりませんので
'値をSheet1に貼り付けるマクロ
としてますが、そのたの部分はこんな感じかな。

Sub データ取得()
　　Dim wb As Workbook
　　If Application.Dialogs(xlDialogOpen).Show = False Then
　　　　MsgBox "きゃんせる"
　　　　Exit Sub
　　Else
　　　　Set wb = ActiveWorkbook
　　　　wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets("Sheet2").Cells
　　　　wb.Close (False)
　　　　Set wb = Nothing
　　End If
End Sub

Sub 印刷()
　　Set myRng = Sheets("Sheet2").Range("A2")
　　Do While myRng <> ""
　　　　'値をSheet1に貼り付けるマクロ
　　　　Sheets("Sheet1").PrintOut
　　　　Set myRng = myRng.Offset(1)
　　Loop
　　Set myRng = Nothing
　　MsgBox "おわったよ。"
End Sub

お礼

ありがとうございました。
教えていただいた記述で思ったとおり動きました。

ですが私のマクロが駄目です。
シート１にはかなり罫線を使用しています。
ですがシート２の値をシート１に貼り付けると
その罫線が消えてしまいます。
例えばシート１のセルA4は罫線で囲まれています。
そこにシート２のA2の値をコピーですが、
シート２には罫線が一切ないため、コピーすると
シート１の罫線が消えてしまいました。
シート１のセルに式を入れてシート２の値を持ってくる方が
いいでしょうか？
でもそれだと印刷の次に次の行の値を持ってくる事が対応できないし。
構想の問題でしょうか？
マクロで行うのは無理なのでしょうか？

補足

'値をSheet1に貼り付けるマクロ
の部分に
　Call　値貼付
として行いました。シート2が3行なら3枚印刷して終了でそれはOKでした。
教えていただいた物はOKなのですが私のマクロが駄目です。
値貼付が駄目でデータが3行あると3枚印刷ですが
3枚とも2行目のデータで印字され結果3枚同じ物が印刷されてしまいます。
Do　Loopを入れたら今度は雛形のみしか印刷されません。
（セルの1行目を指定した文なので当たり前ですが）
2回目は3行目のデータが貼りつかなければいけないのですが
駄目でした。マクロの記録では駄目です。お手上げです。

Sub 値貼付()
行=2
Do While Cells(行, 1).Value <> ""
Sheets("Sheet2").Select
Range("A2").Select
Selection.Copy
Sheets("Sheet1").Select
Range("B4").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("B2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("E2").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("C2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("D21").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("E13").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("E2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("G9").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("F2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B15").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("G2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("G18").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("H2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("D10").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("I2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("C7").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("J2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("G22").Select
ActiveSheet.Paste
行 = 行 + 1
Loop
End Sub