シート2から1行単位でシート1の指定セルに代入し印刷データがある行まで

質問

シート2から1行単位でシート1の指定セルに代入し印刷データがある行まで繰返すマクロ
（QNo.6233212の仕様追加質問です。）

シート1に印刷用の雛形、シート2にデーターシートがあります。
（データーがある行数は都度変更）
シート2のデータから指定したセルの値を
シート1の指定したセルに順次代入したいです。

シート2の２行目の指定したセルの値を
シート1の指定したセルに代入してシート1を１枚印刷。
その後シート2の3行目の指定したセルの値を
シート1の指定したセルに代入してシート1を1枚印刷。
これをシート2のデータがある分繰返。
シート2のデータがなくなったら
「印刷終了」と出て印刷停止。
というのをシート1に作成したボタン一つで行いたく
QNo.6233212で教えていただいた記述で成功しました。

この後仕様変更で、
シート1に代入し印刷前にシート2から代入された値を
Left関数等で編集を行いそれをシート1の別指定セルに代入
シート2→シート1
A2→B4
J2→D21
G2→G18
C2→C2
↓追加
シート1のB4に代入された値の左から４文字目以降をセルA1へ
シート1のG18に代入された値の左から2文字から6文字目までをセルA2へ
以下の用にしましたができません。
↓
Worksheets("Sheet1").Range("A1").Value = Left(D21,4)
Worksheets("Sheet1").Range("A2).Value = Mid(G18,2,5）
ここはマクロでなくシート1のA1,A2に式を入れる方がいいのでしょうか？
（代入された値をSelect Caseでさらに変更も予想有）

Sub 印刷02()
'シート２の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 'セルデータ転記

'【追加した記述】代入された値をさらに編集して別セルへ
Worksheets("Sheet1").Range("A1").Value = Left(D21,4)
Worksheets("Sheet1").Range("A2").Value = Mid(G18,2,5）

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 "印刷終了"
End Sub

回答No.2

merlionXX · ベストアンサー

Case Left(n, 1) = "9" And Len(n) = 14 And InStr(1, n, "-", 1) = 9
と
Case Len(n) = 14 And InStr(1, n, "-", 1) = 9
では左の1文字が9であろうがなかろうが、9字目が - なら
Value = Left(n, 3) & "-" & Mid(n, 4, 11)となるので最初の条件は不要では？
またCase Else以外はすべて14文字なので、これも別にすれば見やすいです。
変数にValueを使いValue=Left(n, 3) & "-" & Mid(n, 4, 11)という書き方はしたことがありません。

で、以下のようにしてみました。

Sub 印刷04()
　　Dim myRng(1 To 4) '変数宣言
　　Dim cpRng '貼付位置をcpRngとする
　　Dim i As Integer
　　Dim n As String, myStr As String
　　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列データがあれば
　　　　　　For i = 1 To 4 'セル数だけ繰り返す
　　　　　　　　.Range(cpRng(i - 1)).Value = myRng(i).Value 'データ転記
　　　　　　Next
　　　　　　'値を編集し別セルへ
　　　　　　.Range("A1").Value = Left(.Range("D21").Value, 4)
　　　　　　.Range("A2").Value = Mid(.Range("G18"), 2, 5)

　　　　　　n = Range("B15")
　　　　　　If Len(n) = 14 Then
　　　　　　　　Select Case True
　　　　　　　　　　Case Left(n, 2) = "9X" And InStr(1, n, "-", 1) = 0 '左2字=9X & -が無
　　　　　　　　　　myStr = Left(n, 3) & "-" & Mid(n, 4)
　　　　　　　　　　Case InStr(1, n, "-", 1) = 9 '9字目が-
　　　　　　　　　　myStr = Left(n, 3) & "-" & Mid(n, 4, 11)
　　　　　　　　　　Case Left(n, 1) = "9" And InStr(1, n, "-", 1) = 0 '左1字=9 & -が無
　　　　　　　　　　myStr = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
　　　　　　　　　　Case InStr(1, n, "-", 1) = 0 '-が無
　　　　　　　　　　myStr = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
　　　　　　　　　　Case Else
　　　　　　　　　　myStr = n
　　　　　　　　End Select
　　　　　　Else
　　　　　　　　myStr = n
　　　　　　End If
　　　　　　.Range("D8").Value = myStr

　　　　　　.PrintOut '印刷
　　　　　　For i = 1 To 4
　　　　　　　　Set myRng(i) = myRng(i).Offset(1) 'データ位置を1行下に
　　　　　　Next i
　　　　Loop '繰り返し
　　　　.Range("A1:A2,B4,D21,G18,B15").ClearContents 'クリア
　　End With
　　For i = 1 To 4
　　Set myRng(i) = Nothing
　　Next
　　MsgBox "印刷終了"
End Sub

お礼

転記した値をさらに編集して別セルへ代入。
動作は問題ありません。ありがとうございました。

一つ困った事が発生しました。
シート２に貼り付けた値なのですが
列によってはセルの左上に三角マークがあり
「数値が文字列として保存されています」となっています。

で値は
12334とか
00009とかあります。

これを転記した場合
12344　→　12344
はいいのですが
00009　→　9　となってしまいます。

00009　→　00009　で転記したいのですが方法がわかりません。

ファイルを指定　→　シート２に貼り付ける時に何か細工をするのか？
　Set wb = Nothing
　と
　End Ifの間に
　wSheet.UsedRange.FormulaR1C1 = wSheet.UsedRange.Value
　を挿入？

シート２に貼り付けた後、細工をするのか？

転記の前に取り込むときに細工をするのか？

web検索等では見つかりません。

お手数かけます。

補足

ありがとうございます。

この-での編集は5種類くらいのエクセルに入れて
運用中で、今の所誤編集は出ていません。

>Case Left(n, 1) = "9" And Len(n) = 14 And InStr(1, n, "-", 1) = 9
>と
>Case Len(n) = 14 And InStr(1, n, "-", 1) = 9
>では左の1文字が9であろうがなかろうが、9字目が - なら
>Value = Left(n, 3) & "-" & Mid(n, 4, 11)となるので最初の条件は不要では？

そうなんです。実は私の記述にも

　'パターン3の編集1　頭が9で計14桁でハイフンがある
　　Case Left(n, 1) = "9" And Len(n) = 14 And InStr(1, n, "-", 1) = 9　'（削除可）
　'パターン3の編集1の答。
　'3-11でハイフン編集→元々9桁目にハイフンがあるので結果は3-5-5になる
　　Value = Left(n, 3) & "-" & Mid(n, 4, 11)　'（削除可）
　'この↑パターン3の編集1と答えについて
　'9頭と9X頭の定義が別文で指定されている
　'それは9頭の計14桁ハイフン無しと9X頭の計14桁ハイフン無し
　'よって計14桁でハイフンがあれば頭9も9Xもそれ以外も
　'パターン3の編集2でモーラされるので省いてもいいのでは？
　'削除’を付けて動作させて問題無しを確認済み

としてあり、（おそらく省いてもいいのでは？）で保留しています。

別のアプローチを教えていただいたので、
本番環境で編集結果を見ています。

結果は、またお礼で回答いたします。

PS
最初の質問から脱線してしまっているのに、
丁寧に対処していただき感謝しています。

愚痴になってしまいますが、完成すると使用者から
（ここまでできるなら、ついでに....）
とどんどん要求されて、私は全然VBAが理解できていないので苦慮しています。

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

回答No.6

merlionXX

おはようございます。
.Range("B10,F3,F10,F13,G10,G13,L10,E19,F19").NumberFormatLocal = "@"
で、書式を文字列に設定するセルが転記先セルすべてを網羅してませんが、これは手作業で書式を変えてあるからですね？
（転記先セル書式を最初から手作業で文字列にしておけば、このコード自体不要ですから）

あと、転記ですが
B2 ⇒ B10
C2 ⇒ O4
D2 ⇒ F3
D2 ⇒ F10
D2 ⇒ F13
E2 ⇒ G10
E2 ⇒ G13
F2 ⇒ H10
F2 ⇒ H13
H2 ⇒ O3
J2 ⇒ L10
K2 ⇒ M10
K2 ⇒ M13
L2 ⇒ O5
M2 ⇒ E19
N2 ⇒ F19
O2 ⇒ A19
Q2 ⇒ D21
R2 ⇒ B6
S2 ⇒ I19
U2 ⇒ J19
Sheet2 ⇒ Sheet1で、Sheet2最初のデータ位置とSheet1のセルの関係は以上のとおりですね？
これがあっていれば、酔眼で眺めてみましたが、不安とおっしゃられたとこもふくめ、別におかしくないですよ。ちゃんと動いているのでしょう？
それではまたおやすみなさい。
むにゃむにゃ(-_-;;

お礼

はい。キチンと動作しています。

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

補足

お礼に入れ忘れました。
＞("B10,F3,F10,F13,G10,G13,L10,E19,F19").NumberFormatLocal = "@"
＞で、書式を文字列に設定するセルが転記先セルすべてを網羅してませんが、
＞これは手作業で書式を変えてあるからですね？
＞（転記先セル書式を最初から手作業で文字列にしておけば、このコード自体不要ですから）

データ元のシート２に
エラーマーク（セルの左上の緑の三角マーク）
があるセルの転記先だけを入力しました。

回答No.5

merlionXX

> ＞Do While myRng(2) <> ""
> の（２）は左から2列→Ｂ列
> だと思って質問しました。

まったく違います。
括弧内の数字は配列の添え字です。
（「配列」については、ここで簡単には説明できませんので、お時間のあるときにご自分で検索するなりしてみてください）

で、現在変更して
Set myRng(1) = .Range("B2")
としてるなら、B列にデータがある間であれば
Do While myRng(1) <> ""
としなければなりません。

なお、またうるさいことを言って嫌われそうですが、回答を自分で自由に修正できるくらいまで理解できないうちは、質問に掲示する配置（列や行、セル番地）は実際のものを書いた方がいいですよ。
そうしないと、お互いに誤解をまねき混乱の元になりますから。

で、これで今回の質問は解決ですね。
では、わたしはこれから飲み会です。
(〃^o^)ノロ*ロヾ(´∇｀=) Cheers!!

お礼

●回答NO.4お礼の続き↑

'転記後の値を文字取出をして別セルへ
'O3の左から10文字をC3,C13へ　
.Range("C3,C13").Value = Left(.Range("O3").Value, 10)
'03の左から11番目から6文字までをC10へ　
.Range("C10").Value = Mid(.Range("O3"), 11, 6)

'O4に転記後の値を編集してD10,D13へ
'編集対象値を決定
n = Range("O4")
'値が14文字である事
If Len(n) = 14 Then
Select Case True
'左2字=9X & -が無
Case Left(n, 2) = "9X" And InStr(1, n, "-", 1) = 0
'3-11で編集
myStr = Left(n, 3) & "-" & Mid(n, 4)
'9字目が-
Case InStr(1, n, "-", 1) = 9
'3-5-5で編集(3文字目と4文字目に-を入れれば3-5-5）
myStr = Left(n, 3) & "-" & Mid(n, 4, 11)
'左1字=9 & -が無
Case Left(n, 1) = "9" And InStr(1, n, "-", 1) = 0
'5-5-2-2で編集
myStr = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
'-が無
Case InStr(1, n, "-", 1) = 0
'3-5-2-2で編集
myStr = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
'上記ケースでない14文字
Case Else
'編集対象の値を使用
myStr = n
End Select
'編集対象の値が14文字でない
Else
'編集対象の値を使用
myStr = n
End If
'編集した値を転記する場所
.Range("D10,D13").Value = myStr

'O5に転記後の値を編集してC19へ
n = Range("O5")
If Len(n) = 14 Then
Select Case True
Case Left(n, 2) = "9X" And InStr(1, n, "-", 1) = 0
myStr = Left(n, 3) & "-" & Mid(n, 4)
Case InStr(1, n, "-", 1) = 9
myStr = Left(n, 3) & "-" & Mid(n, 4, 11)
Case Left(n, 1) = "9" And InStr(1, n, "-", 1) = 0
myStr = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case InStr(1, n, "-", 1) = 0
myStr = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case Else
myStr = n
End Select
Else
myStr = n
End If
.Range("C19").Value = myStr
'印刷
.PrintOut

'↓【データ変更時変更場所】
'↓データ数に合わせてToの右の数字を変える事
For i = 1 To 21
'データ位置を1行下に
Set myRng(i) = myRng(i).Offset(1)
Next i
Loop '繰り返し
'クリア
'↓【データ変更時変更場所】データ数の増減でここを変更
'↓【転記位置変更時変更場所】
'↓データの転記先だけが変更時もここを変更
.Range("B10,O4,F3,F10,F13,G10,G13,H10,H13,O3,L10,M10,M13,O5,E19,F19,A19,D21,B6,I19,J19,C3,C10,C13,C19,D10,D13").ClearContents
End With

'↓【データ変更時変更場所】
'↓データ数に合わせてToの右の数字を変える事
For i = 1 To 21
Set myRng(i) = Nothing
Next
MsgBox "印刷終了"
End Sub

回答No.4

merlionXX

> A列は無視してB列以降においてデータがあるまで繰り返すになってしまいました。

> Do While myRng(2) <> "" 'B列データがあれば

With Sheets("Sheet2")
　　　　Set myRng(1) = .Range("A2") 'データ位置設定
　　　　Set myRng(2) = .Range("J2") '同
　　　　Set myRng(3) = .Range("G2") '同
　　　　Set myRng(4) = .Range("C2") '同

と設定していますので、gx9wxさんが書き換えていなければ、myRng(2)はSheet2のJ列です。B列はどこも参照していませんのでおっしゃる意味がわかりません。
もしJ列のデータがあるまで繰り返すのでよければ、
Do While myRng(2) <> ""
　とするだけでOKです。

お礼

すみませんでした。
使用者の要求を全て取入れ自分でメンテできるように
以下の記述になりました。
不安な所は、
・If MsgBox("印刷しますか？", vbYesNoCancel) = vbYes Then
を追加した事
・Set myRng(1)から(21)で1つのデータを複数のセルに転記する為
同じセルが並んでいる事
・Left関数編集し別セルへの転記が2ケ所で
.Range("C3,C13").Value = Left
となった事
・ハイフン挿入がデータが2個、転記先が3個の為
Select Case文が2回になった事と1回目は転記先が
.Range("D10,D13").Value = myStr
となった事です。
どうもいろいろとありがとうございました。
記述は回答NO.4とNO.5のお礼に分けて載せました。
---
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
If MsgBox("印刷しますか？", vbYesNoCancel) = vbYes Then
Call データ転記印刷ハイフン編集
Else
Exit Sub ''何もしない。
End If
End Sub
----
Sub データ転記印刷ハイフン編集()
'↓【データ変更時変更場所】データ数の増減でここを変更
Dim myRng(1 To 21) '変数宣言
Dim cpRng '転記先をcpRngとする
Dim i As Integer
Dim n As String, myStr As String
With Sheets("Sheet2")
'データ位置設定
Set myRng(1) = .Range("B2")
Set myRng(2) = .Range("C2")
Set myRng(3) = .Range("D2")
Set myRng(4) = .Range("D2")
Set myRng(5) = .Range("D2")
Set myRng(6) = .Range("E2")
Set myRng(7) = .Range("E2")
Set myRng(8) = .Range("F2")
Set myRng(9) = .Range("F2")
Set myRng(10) = .Range("H2")
Set myRng(11) = .Range("J2")
Set myRng(12) = .Range("K2")
Set myRng(13) = .Range("K2")
Set myRng(14) = .Range("L2")
Set myRng(15) = .Range("M2")
Set myRng(16) = .Range("N2")
Set myRng(17) = .Range("O2")
Set myRng(18) = .Range("Q2")
Set myRng(19) = .Range("R2")
Set myRng(20) = .Range("S2")
Set myRng(21) = .Range("U2")
End With
'myRngの(1)から順に転記する先を指定する
'↓【データ変更時変更場所】データ数の増減でここを変更
'↓【転記位置変更時変更場所】
'↓データの転記先だけが変更時もここを変更
cpRng = Split("B10,O4,F3,F10,F13,G10,G13,H10,H13,O3,L10,M10,M13,O5,E19,F19,A19,D21,B6,I19,J19", ",") '転記先配列化
With Sheets("Sheet1")
.Range("B10,F3,F10,F13,G10,G13,L10,E19,F19").NumberFormatLocal = "@"
'B列にデータがあれば繰り返す
Do While myRng(1) <> ""

'↓【データ変更時変更場所】
'↓データ数に合わせてToの右の数字を変える事
For i = 1 To 21 'セル数だけ繰り返す
.Range(cpRng(i - 1)).Value = myRng(i).Value 'データ転記
Next

●回答NO.5お礼に続く↓

補足

大変申し訳有りません。
＞Set myRng(1) = .Range("A2") 'データ位置設定
の存在を忘れていました。

＞Do While myRng(2) <> ""
の（２）は左から2列→Ｂ列

だと思って質問しました。

現在
Set myRng(1) = .Range("B2")
Set myRng(2) = .Range("C2")
Set myRng(3) = .Range("D2")
・
・
・
・
となってます。
という事は
＞Do While myRng(1) <> ""
のままでも良いとなりますがその解釈でいいでしょうか？

ダミーデータで
A列は100行
B～J列は２行。

＞Do While myRng(1) <> ""
＞Do While myRng(2) <> ""
＞Do While myRng(3) <> ""

上記のいずれの記述でも2枚印刷で終了しました。

回答No.3

merlionXX

gx9wxさん、こんにちは。
確認しますが、Sheet2のほうにはちゃんと表示されているのですね？
それがこのマクロでSheet1に持ってきたときに頭の0が消えてしまうということですね？
いろいろ問題が出てきますね。（笑）
でもちょっと待ってください。
00009　→　9　となるのは何もこもマクロだけのことではなく、標準書式のセルに手で入力してもそうなるのでは？
これはエクセルの一般機能の問題です。いわばエクセルの「おせっかい」です。
手入力で00009としたい場合、どうします？普通はセルの書式を「標準」から「文字列」に変えるんじゃないですか？
だったらマクロも同じこと。
With Sheets("Sheet1")と
　　Do While myRng(1) <> "" 'A列データがあれば
のあいだに
　　 .Range("A1:A2,B4,D8,B15,G18,D21").NumberFormatLocal = "@"
を挿入してみてください。
転記先セルの書式を文字列に変えるコードです。
（わざわざマクロを使わなくとも、最初から手作業で転記先セル書式を文字列にしておいてもいいですけど）

あと、１点、gx9wxさんに謝らなくてはならないことがあります。
前回のご質問のマクロでSheet2からSheet1にデータを転記させる作業で、わたしは「代入」という言葉を使いました。
自分ではいったん変数に入れて（つまり代入して）持ってくるつもりだったので「代入」と書いてしまったのですが、いざコードを書いたら、実際に変数に代入したのはセル番地で、データではありませんでした。
単にセルからセルにデータを転記することは代入とは言いませんので、これは不適切な書き方でした。
すっかりgx9wxさんに誤解をさせてしまったようで、今回のご質問に「シート1の指定セルに代入」とお書きですね。訂正いたします。
ごめんなさい。　(o。_。)oペコッ.

余談ですが、

> 愚痴になってしまいますが、完成すると使用者から
> （ここまでできるなら、ついでに....）

これ、わたしもまったく同じです。
でもこれがあるから「やらなくちゃ！」と思い、向上もできるんだと思っています。
「要求は向上の母」です。
えらそうなこと書きましたがわたしもまだまだ未熟ものです。
いっしょにがんばりましょう！

お礼

とんちんかんな補足ですいませんでした。

書式設定、文字列、

.Range("A1:A2,B4,D8,B15,G18,D21").NumberFormatLocal = "@"

こちらもキチンと動作しました。

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

補足

ありがとうございます。

＞確認しますが、Sheet2のほうにはちゃんと
＞表示されているのですね？
＞それがこのマクロでSheet1に持ってきたときに
＞頭の0が消えてしまうということですね？

はい。そのとうりです。

で考えたのが、
セルに手入力する時に
00009と入力すると9になります。
'00009と入力するとセルの表示には　'　は無く　00009　と表示されるので
記述に　'　を入れるのかな？と

Set myRng(1) = .Range("A2")
↓
Set myRng(1) = .Range("'A2")
では駄目で

cpRng = Split("B4,D21,
↓
cpRng = Split("'B4,D21,

でも駄目で、おっしゃるとうり

＞手入力で00009としたい場合、どうします？
＞普通はセルの書式を「標準」から「文字列」に変えるんじゃないですか？

をひらめいて雛形であるシート１の文字列が転記される部分を
書式設定で、「文字列」にすれば？と思いましたが
書式設定してもシート２の値が転記された時、
シート２の書式設定を引き継いできて多分駄目だろうと実践しなかったです。

でも一番最初に
「転記したら罫線が消えてしまうのです」
と質問し解決していた事を思い出して
「大丈夫のはず」
とシート１の雛形に書式設定をしたらできました。
00009　→　00009　で転記されました。

で今ほど回答を拝見いたしました。

.Range("A1:A2,B4,D8,B15,G18,D21").NumberFormatLocal = "@"

こちらも試して見ます。

●もう一点なんですが

＞Do While myRng(1) <> "" 'A列データがあれば
の部分ですが
A列は無視してB列以降においてデータがあるまで繰り返すになってしまいました。
A列は1,00行の値があり、B列以降は全部の列が100行（行数は統一）とかで
で毎日B列以降の行数が統一で変わるようです。（70行とか113行とか）
↓
Do While myRng(2) <> "" 'B列データがあれば

だけ変更で後の記述は変更しなくても大丈夫でしょうか？

＞あと、１点、gx9wxさんに謝らなくてはならないことがあります。

いえ、わざわざすいません。

回答No.1

merlionXX

> '【追加した記述】代入された値をさらに編集して別セルへ
> Worksheets("Sheet1").Range("A1").Value = Left(D21,4)
> Worksheets("Sheet1").Range("A2").Value = Mid(G18,2,5）

VBAでセルを指定するのにLeft(D21,4)やMid(G18,2,5）ではまずいです。
ちゃんとRangeで指定しましょう。
あと、Worksheets("Sheet1")も、その前にWithでくくってあるので不要です。
A1:A2もクリアしていいんですよね？
こんな感じかな。

Sub 印刷03()
　　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列のデータ位置が空白でなければ
　　　　　　For i = 1 To 4 'データの数だけ繰り返す
　　　　　　　　.Range(cpRng(i - 1)).Value = myRng(i).Value 'セルデータ転記
　　　　　　Next
　　　　　　'【追加した記述】代入された値をさらに編集して別セルへ
　　　　　　.Range("A1").Value = Left(.Range("D21").Value, 4)
　　　　　　.Range("A2").Value = Mid(.Range("G18"), 2, 5)
　　　　　　.PrintOut '印刷
　　　　　　For i = 1 To 4
　　　　　　　　Set myRng(i) = myRng(i).Offset(1) 'データ位置を1行下に設定
　　　　　　Next i
　　　　Loop '繰り返し
　　　　.Range("A1:A2,B4,D21,G18,B15").ClearContents 'クリア
　　End With
　　For i = 1 To 4
　　Set myRng(i) = Nothing '後処理
　　Next
　　MsgBox "印刷終了"
End Sub

お礼

ありがとうございました。思ったとうりできました。
---------------
【お詫び】
説明に不備が有り不備の部分まで解釈していただき正しい説明をしてくださいまして
ありがとうございます。

　>シート1のB4【→記述がD21なのでD21の間違い】に代入された値の
　>左から４文字目以降【→Leftですから左から４文字目までの間違い】をセルA1へ
　>シート1のG18に代入された値の左から2文字から6文字目までをセルA2へ
　>以下の用にしましたができません。
　>↓
　>Worksheets("Sheet1").Range("A1").Value = Left(D21,4)
　>Worksheets("Sheet1").Range("A2).Value = Mid(G18,2,5）
　【Range("A2）→Range("A2")の間違い】
--------------
【別件】
別のエクセルで以下のようにG1の値をCaseで決めた法則で
値の間に-を入れてH1に代入。
G列の値があるまで繰返すという以下の記述で

行 = 1
Do
If Cells(行, 7).Value = "" Then Exit Do
n = Cells(行, 7)
Select Case True
Case Left(n, 2) = "9X" And Len(n) = 14 And InStr(1, n, "-", 1) = 0
Value = Left(n, 3) & "-" & Mid(n, 4)
Case Left(n, 1) = "9" And Len(n) = 14 And InStr(1, n, "-", 1) = 9
Value = Left(n, 3) & "-" & Mid(n, 4, 11)
Case Len(n) = 14 And InStr(1, n, "-", 1) = 9
Value = Left(n, 3) & "-" & Mid(n, 4, 11)
Case Len(n) = 14 And InStr(1, n, "-", 1) = 0 And Left(n, 1) = "9"
Value = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case Len(n) = 14 And InStr(1, n, "-", 1) = 0
Value = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case Else
Value = n
End Select
Cells(行, 8) = Value
行 = 行 + 1
Loop

これを以下のように修正して

　n = Range("B15")
Select Case True
Case Left(n, 2) = "9X" And Len(n) = 14 And InStr(1, n, "-", 1) = 0
Value = Left(n, 3) & "-" & Mid(n, 4)
Case Left(n, 1) = "9" And Len(n) = 14 And InStr(1, n, "-", 1) = 9
Value = Left(n, 3) & "-" & Mid(n, 4, 11)
Case Len(n) = 14 And InStr(1, n, "-", 1) = 9
Value = Left(n, 3) & "-" & Mid(n, 4, 11)
Case Len(n) = 14 And InStr(1, n, "-", 1) = 0 And Left(n, 1) = "9"
Value = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case Len(n) = 14 And InStr(1, n, "-", 1) = 0
Value = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case Else
Value = n
End Select
　.Range("D8").Value =　Value

教えていただいた記述の
.PrintOut '印刷
の前に追加し一応動いていますが大丈夫でしょうか？
お手数かけます。m(__)m

補足

ありがとうございます。

参考書で見つけました。エクセルの関数にならっての記述は駄目なのですね。

参考書のとうりに記述で

元 = Range("D21").Value
左 = Left(元, 4)
Range("A1").Value = 左

基 = Range("G18").Value
右 = Mid(基, 2, 5)
Range("A2").Value = 右

これで動いたので質問を取り下げようと思いました。
でも回答のほうが早かったです。(^_^.)

回答ですと

.Range("A1").Value = Left(.Range("D21").Value, 4)
.Range("A2").Value = Mid(.Range("G18"), 2, 5)

この2行でできてしまうのですか？＼(◎o◎)／！
すぐ試してあとでお礼に返事いたします。

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