| |
こんばんは、ＮＡＯです。またお世話になります。
下記のコードは、データシートの内容を一部づつ作業用シートにコピーし、作業用シートからラベルシートに転記し、印刷、次のデータを同じようにコピー、転記、印刷したいと思って作成したのですが、うまく思っているように出来ません。
どこがまずいのかご指摘ねがいたいと思います。よろしくお願いします。
（データシート）・・・データ数は一定ではありません
a b c d
1 番号 名前 品名 備考
2 1 井上 定規 １組
3 2 坂本 鉛筆 １ダース
4 3 中村 ペン 赤色
. . . . .
. . . . .
まず、データシートの番号１〜５（２行目から６行目）を作業シートのセル"A1"にコピーする。
作業用シートの内容をラベルシートの右側半分の所定の位置に転記する。
引き続き、データシートの番号６〜１０（７行目から１１行目）を作業シートのセル"A1"にコピーする。
作業用シートの内容をラベルシートの左側半分の所定の位置に転記する。
ラベルシートを印刷する。
上記の手順を、データシートの最終番号まで繰り返す。
転記先のラベルシートの所定の位置ですが、一寸文章で書くとややこしいのですが、次のとおりです。
（作業シート）⇒（ラベルシート右側） （ラベルシートの左側）
１行目の Ａ１ ⇒ Ｍ９ ＡＢ９
データ Ｂ１ ⇒ Ｃ２ Ｒ２
Ｃ１ ⇒ Ｅ９ Ｔ９
Ｄ１ ⇒ Ｈ２ Ｗ２
２行目の Ａ２ ⇒ Ｍ１９ ＡＢ１９
データ Ｂ２ ⇒ Ｃ１２ Ｒ１２
Ｃ２ ⇒ Ｅ１９ Ｔ１９
Ｄ２ ⇒ Ｈ１２ Ｗ１２
以下、５行目まで同じ間隔でコピーします。
データシート上のコマンドボタンにより転記。コードは次のようになっています。
Private Sub CommandButton1_Click()
Dim lstrow As Integer, a As Integer, m As Integer, n As Integer, h As Integer,i As Integer, j As Integer, k As Integer, p As Integer, q As Integer
Application.ScreenUpdating = False
'データシートより５行づつ、作業用シートに取り込む
Worksheets("データ").Activate
lstrow = Worksheets("データ").Range("a65536").End(xlUp).Row
a = lstrow
m = WorksheetFunction.RoundUp(a / 5, 0)
For z = 1 To m
h = z * 5 - 3
i = z * 5 + 1
Worksheets("データ").Range("a" & h & ":d" & i).Copy Destination:=Worksheets("作業用").Range("a1")
'作業用シートのデータをラベルシートに転記する
For n = 1 To 2 '１シートに１０行分転記する
'名前
For j = h To i
If n Mod 2 = o Then
Worksheets("ラベル").Cells(j * 10 - 18, 3).Value =Worksheets("作業用").Cells(j - 1, 2).Value
Else: Worksheets("ラベル").Cells(j * 10 - 18, 18).Value = Worksheets("作業用").Cells(j + 4, 2).Value
End If
Next j
'備考
For k = h To i
If n Mod 2 = o Then
Worksheets("ラベル").Cells(k * 10 - 18, 8).Value = Worksheets("作業用").Cells(k - 1, 4).Value
Else: Worksheets("ラベル").Cells(k * 10 - 18, 23).Value = Worksheets("作業用").Cells(k + 4, 4).Value
End If
Next k
'品名
For p = h To i
If n Mod 2 = o Then
Worksheets("ラベル").Cells(p * 10 - 11, 5).Value = Worksheets("作業用").Cells(p - 1, 3).Value
Else: Worksheets("ラベル").Cells(p * 10 - 11, 20).Value = Worksheets("作業用").Cells(p + 4, 3).Value
End If
Next p
'番号
For q = h To i
If n Mod 2 = o Then
Worksheets("ラベル").Cells(q * 10 - 11, 13).Value = Worksheets("作業用").Cells(q - 1, 1).Value
Else: Worksheets("ラベル").Cells(q * 10 - 11, 28).Value = Worksheets("作業用").Cells(q + 4, 1).Value
End If
Next q
Next n
'ラベルシートの印刷
MsgBox "用紙をセットしてください"
Worksheets("ラベル").Activate
ActiveSheet.PrintOut copies:=1
Next z
MsgBox "すべての印刷終了"
Application.ScreenUpdating = True
End Sub
上記を作動させますと、１回目の番号１から５の内容をラベルシートの左側にうまく敵されますが、右側には何も転記されません。
うまく説明出来ておらず、分かりづらい質問ですがよろしくお願いします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
