| |
momo さん、おはようございます。
>【３００近くある画像を店舗ごとに振り分けて印刷したいんです。】
>
>(店名) 画像１ 画像２ 画像３ （シート名）
>Ａ店 1 1
>Ｂ店 1
>Ｃ店 1 1 1
リストと画像が同じファイル上にあるとして。
新しいブックに、見出しシートと、該当の写真をコピーしてまとめて印刷します。
CloseをSaveに変えると、保存しておくこともできます。
Sub test()
Dim Rmax As Long, Cmax As Long, RR&, CC&
Dim ws1 As Worksheet, wb1 As Workbook, wb2 As Workbook, nsc As Integer
Const Lsht As String = "分配リスト" '分配リストのシート名
'
With Application
.ScreenUpdating = False '画面の更新を抑える
nsc = .SheetsInNewWorkbook '元の新しいブックのシート数
.SheetsInNewWorkbook = 1
Set wb1 = .ActiveWorkbook
End With
'
On Error Resume Next
Set ws1 = wb1.Worksheets(Lsht)
On Error GoTo 0
'
If ws1 Is Nothing Then
MsgBox wb1 & "に" & Lsht & "がありません", vbExclamation
Else
'開始
With ws1
Rmax = .Range("A65536").End(xlUp).Row
Cmax = .Range("IV1").End(xlToLeft).Column
End With
For RR& = 2 To Rmax
Set wb2 = Application.Workbooks.Add
With wb2.Worksheets(1)
.Range("A2").Value = ws1.Cells(RR&, 1) '見出し
With .Range("A2:I12")
.Merge
With .Font
.Size = 72
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ShrinkToFit = True
End With
With .PageSetup
.PrintArea = "$A$1:$I$13"
.CenterHorizontally = True
.CenterVertically = True
End With
End With
'新しいブックにコピー
For CC& = 2 To Cmax
If ws1.Cells(RR&, CC&).Value = 1 Then
With wb2
wb1.Worksheets(ws1.Cells(1, CC&).Value).Copy after:=.Worksheets(.Worksheets.Count)
End With
End If
Next
With wb2
If .Worksheets.Count > 1 Then .Worksheets.PrintOut
'
.Saved = True
.Close
DoEvents
End With
Set wb2 = Nothing
Next
End If
'
With Application
.SheetsInNewWorkbook = nsc '元の新しいブックのシート数
.ScreenUpdating = True
End With
End Sub
たとえばこんな感じです。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 07/5/21(月) 8:28 -
