| |
▼ニャンソ さん：
こんにちは
かなりkanabunさんのものと重なっているんだろうとは思いますが。
（きっと）kanabunさんの構成と同じく、抽出ブックである Book2 側にニャンソさんが担当する地区を入力して実行してください。
かってながらBook1,Book2は、以下のようになっているということが前提です。
(Book1)
タイトル行が７行あるということですが、７行目には、ユニークな項目名がセットされていると認識しています。
(Book2)
・B〜F列が抽出・印刷領域。
・G列は空白列
・H列、H1 に "地区" (Book1 の D7 と同じ文字列）、H2から下に、担当する地区コード（１つでも３つでも１００個でもＯＫ）
また、印刷は Book2の B〜F列のみを対象にしています。
kanabunさんのアドバイスにあったように「環境にやさしい」コードにしています。
最終的には
.Columns("B:F").PrintPreview
これを
.Columns("B:F").PrintOut
にしてください。
なお、このマクロは Book1,Book2,Book3 とは別の独立したマクロブックに書きます。
実行時には ３つのブックがすべて開かれているということを前提にしています。
Sub Sample2()
Dim dicP As Object
Dim dicG As Object
Dim v As Variant
Dim c As Range
Dim sv3 As Variant
Dim wb As Workbook
Dim sh As Worksheet
Dim x As Long
Dim i As Long
Dim grp As Variant
Application.ScreenUpdating = False
Set wb = Workbooks("Book1.xls")
Set dicP = CreateObject("Scripting.Dictionary")
Set dicG = CreateObject("Scripting.Dictionary")
With Workbooks("Book3.xls").Sheets(1)
For Each c In .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
dicP(c.Value) = c.Offset(, -1).Value
dicG(c.Offset(, -1).Value) = True
Next
End With
With Workbooks("Book2.xls").Sheets(1)
sv3 = .Range("B7:F7").Value
.Range("I1").Value = wb.Sheets(1).Range("E7").Value
For Each grp In dicG
.Range("B7:F7").Value = Array(wb.Sheets(1).Range("F7").Value, _
wb.Sheets(1).Range("G7").Value, _
wb.Sheets(1).Range("G7").Value, _
wb.Sheets(1).Range("I7").Value, _
wb.Sheets(1).Range("J7").Value)
.Range("H2", .Range("H" & .Rows.Count).End(xlUp)).Offset(, 1).Value = grp
Intersect(.Range("B1", .UsedRange), .Columns("B:F")).Offset(7).ClearContents
For x = 1 To 2
Set sh = wb.Sheets(x)
Call maintGrp(sh, True, dicP)
If x = 1 Then
i = 7
Else
i = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("B" & i & ":" & "F" & i).Value = .Range("B7:F7").Value
End If
sh.Range("B7", sh.Range("B" & sh.Rows.Count).End(xlUp)).Resize(, 9).AdvancedFilter _
Action:=xlFilterCopy, CriteriaRange:=.Range("H1").CurrentRegion, _
CopyToRange:=.Cells(i, "B").Resize(, 5), Unique:=False
If x <> 1 Then .Rows(i).Delete
Call maintGrp(sh, False)
Next
.Range("B7", .Range("B" & .Rows.Count).End(xlUp)).Resize(, 5).Sort _
Key1:=.Columns("B"), Order1:=xlAscending, Header:=xlYes
.Range("B7:F7").Value = sv3
.Columns("B:F").PrintPreview
Next
Intersect(.Range("B1", .UsedRange), .Columns("B:F")).Offset(7).ClearContents
.Columns("I").Clear
.Range("B7:F7").Value = sv3
End With
Application.ScreenUpdating = True
End Sub
Private Sub maintGrp(sh As Worksheet, wt As Boolean, Optional dicP As Object)
Dim c As Range
With sh.Range("F8", sh.Range("F" & sh.Rows.Count).End(xlUp))
If wt Then
For Each c In .Cells
c.Offset(, -1).Value = dicP(c.Value)
Next
Else
.Offset(, -1).ClearContents
End If
End With
End Sub
|
|
UO3
- 12/12/27(木) 12:33 -
