以下のようなマクロを作りましたが、帳票を印刷すると１枚印刷されます。
ですが、この帳票がA５サイズの決まりがあり、かつプリンタがA4しか用紙を入れることができないので、
そのため、一度にA5サイズの帳票を２枚合わせた形で印刷をさせたいと考えています。
A４用紙に左側（名簿の１番目）右側（名簿の２番目）
次も、名簿の３番目・４番目と連続印刷をしたいのですが、どのようにすれば良いのでしょうか。
勉強不足で申し訳ございませんが、ご指南くださいますようお願いいたします。
Sub 帳票印刷()
Dim LastRow As Long
Dim i As Long
Dim myNo As Variant
With Worksheets("名簿")
LastRow = .Cells(Application.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
myNo = .Range("A" & i).Value
With Worksheets("印刷用")
.Range("C4").Value = myNo
.PrintPreview
.PrintOut Copies:=1, Collate:=True
End With
Next i
End With
End Sub
以下のようなマクロを作りましたが、帳票を印刷すると１枚印刷されます。
ですが、この帳票がA５サイズの決まりがあり、かつプリンタがA4しか用紙を入れることができないので、
そのため、一度にA5サイズの帳票を２枚合わせた形で印刷をさせたいと考えています。
A４用紙に左側（名簿の１番目）右側（名簿の２番目）
次も、名簿の３番目・４番目と連続印刷をしたいのですが、どのようにすれば良いのでしょうか。
勉強不足で申し訳ございませんが、ご指南くださいますようお願いいたします。
Sub 帳票印刷()
Dim LastRow As Long
Dim i As Long
Dim myNo As Variant
With Worksheets("名簿")
LastRow = .Cells(Application.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
myNo = .Range("A" & i).Value
With Worksheets("印刷用")
.Range("C4").Value = myNo
.PrintPreview
.PrintOut Copies:=1, Collate:=True
End With
Next i
End With
End Sub
Sub 記入()
Dim testno As String
Dim testrow As Long
Dim basedata(1 To 10) As String
Dim weight(1 To 16) As Double
Sheets("sh3").Select
'(1)
testno = Range("B23").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sheet3").Select
Cells(3, 1) = testno
For i = 1 To 10
Cells(3, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(3, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
'(1)
testno = Range("B24").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(4, 1) = testno
For i = 1 To 10
Cells(4, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(4, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
この間同様文12個あり
'(1)
testno = Range("B37").Value
If testno = "" Then
End
End If
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(17, 1) = testno
For i = 1 To 10
Cells(17, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(17, i + 11) = weight(i)
Next i
End Sub
Sub 記入()
Dim testno As String
Dim testrow As Long
Dim basedata(1 To 10) As String
Dim weight(1 To 16) As Double
Sheets("sh3").Select
'(1)
testno = Range("B23").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sheet3").Select
Cells(3, 1) = testno
For i = 1 To 10
Cells(3, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(3, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
'(1)
testno = Range("B24").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(4, 1) = testno
For i = 1 To 10
Cells(4, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(4, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
この間同様文12個あり
'(1)
testno = Range("B37").Value
If testno = "" Then
End
End If
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(17, 1) = testno
For i = 1 To 10
Cells(17, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(17, i + 11) = weight(i)
Next i
End Sub
Sub 記入()
Dim testno As String
Dim testrow As Long
Dim basedata(1 To 10) As String
Dim weight(1 To 16) As Double
Sheets("sh3").Select
'(1)
testno = Range("B23").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sheet3").Select
Cells(3, 1) = testno
For i = 1 To 10
Cells(3, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(3, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
'(1)
testno = Range("B24").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(4, 1) = testno
For i = 1 To 10
Cells(4, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(4, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
この間同様文12個あり
'(1)
testno = Range("B37").Value
If testno = "" Then
End
End If
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(17, 1) = testno
For i = 1 To 10
Cells(17, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(17, i + 11) = weight(i)
Next i
End Sub
２つのエクセルのブックがあり、
ブックAの[シート１]には、
A列 B列 C列 D列 E列
コード 社名 品名 注文 合計
12345 グルメ社 カレー 400 800
78910 AA社 豆 100 250
12345 グルメ社 カレー 400 800
44123 ラック社 にんじん 350 400
のように、過去の注文データが1万件近くならんでおります。
ブックBの[現在]シートには、同じ列に同じ項目が並んでいるのですが、
A列 B列 C列 D列 E列
コード 社名 品名 注文 合計
12345 グルメ社 カレー 400 800
89123 100 250
55158 800
44123 ラック社 にんじん 350 400
のように、コード以外空欄というセルがあり、それが4千件あります。
ブックBにてB列が空欄の場合、ブックAのB・C・D列の値を転記する方法がわからず
困っております。
Sub ああ()
Dim lRow As Long
Dim i As Long
Dim エラーコード(25000)
Workbooks.Open Filename:=("C:\Documents and Settings\PC01\デスクトップ\bookA.xls")
Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate
Sheets("sheet1").Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row
x = ""
cnt = 0
For i = 4 To lRow
Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate
Sheets("sheet1").Select
If Cells(i, 2).Value = "" Then
JAN = Cells(i, 1)
Windows("book2.xls").Activate
Sheets("現在").Select
商品datarec = Cells(Rows.Count, 1).End(xlUp).Row
x = ""
Set 範囲 = Range(Cells(2, 1), Cells(商品datarec, 1))
検索 = JAN
On Error Resume Next
x = Application.WorksheetFunction.match(検索, 範囲, 0)
On Error GoTo 0
If x = "" Then
cnt = cnt + 1
エラーコード(cnt) = JAN
Else
Windows("book2.xls").Activate
Sheets("現在").Select
メーカー名 = Cells(x + 1, 5).Value
品名 = Cells(x + 1, 6).Value
Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate
Sheets("sheet1").Select
Cells(i, 2) = 社名
Cells(i, 3) = 品名
End If
End If
Next i
If cnt <> 0 Then
MsgBox "リストにない商品が" + Str(cnt) + "件ありました。" + vbCrLf
End If
End Sub
というプログラムを組みました。宣言は強制させておりません。
途中で混乱してきたためおかしなコードになっております。
すみませんが、お願い致します。
