| |
Sub MyPrint()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Snum As Long, Lnum As Long
Dim Ck As Variant
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
If WorksheetFunction.Count(Sh2.Range("B1:C1")) < 2 Then GoTo ELine
Snum = CLng(Sh2.Range("B1").Value)
Lnum = CLng(Sh2.Range("C1").Value)
With Application
If IsError(.Match(Snum, Sh1.Range("A:A"), 0)) Then GoTo ELine
If IsError(.Match(Lnum, Sh1.Range("A:A"), 0)) Then GoTo ELine
For i = Snum To Lnum
Ck = .Match(i, Sh1.Range("A:A"), 0)
If Not IsError(Ck) Then
Sh2.Cells(3, 2).Value = Sh1.Cells(Ck, 2).Value
Sh2.Cells(4, 2).Value = Sh1.Cells(Ck, 3).Value
Sh2.Cells(5, 2).Value = Sh1.Cells(Ck, 4).Value
Sh2.Range("A3:B5").PrintOut Copies:=1
End If
Next i
End With
ELine:
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub
または
Sub MyPrint2()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Snum As Long, Lnum As Long
Dim Ck1 As Variant, Ck2 As Variant
Dim MyR As Range, C As Range
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
If WorksheetFunction.Count(Sh2.Range("B1:C1")) < 2 Then GoTo ELine
Snum = CLng(Sh2.Range("B1").Value)
Lnum = CLng(Sh2.Range("C1").Value)
With Application
Ck1 = .Match(Snum, Sh1.Range("A:A"), 0)
Ck2 = .Match(Lnum, Sh1.Range("A:A"), 0))
End With
If IsError(Ck1) Or IsError(Ck2) Then GoTo ELine
On Error GoTo ELine
Set MyR = Sh1.Range("A" & Ck1 & ":A" & Ck2).SpecialCells(2, 1)
For Each C In MyR
With Sh2.Range("B3:B5")
.Value = WorksheetFunction _
.Transpose(C.Offset(, 1).Resize(, 3).Value)
.PrintOut Copies:=1
End With
Next
Set MyR = Nothing
ELine:
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub
で、どうでしょーか ?
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
