| |
こんばんは。
コードの見直しをしてみました。
私の力量では、
外側のループを職種・氏名で、内側ループを月別に回すため、
職種と氏名の一覧シートでもあればよいのですが、
それがないので、4月シートにオートフィルターをかけて、
職種別に抽出し、その抽出された一人一人に対して、
4月から9月までマッチした人のデータを集計表に入力するようにしました。
これで、職種を選ぶとその職種全員のデータを印刷することが出来ます。
ユーザーフォームで職種を選び、コマンドボタンなどで実行すれば、
その職種すべての人の印刷が出来ます。
データの貼り付け位置については、そちらで変えてください。
前回こちらが提示した集計表では、全員分抽出されています。
試してください。
Sub test()
Dim myR2 As Range, c As Range
Dim myAry As Variant, myTen1 As Variant, myTen2 As Variant
Dim i As Integer, j As Variant
Dim Ans
Application.ScreenUpdating = False
myAry = Array("４月", "５月", "６月", "７月", "８月", "９月") '全角 シート名も全角で
With Worksheets("４月")
If .AutoFilterMode = True Then .AutoFilterMode = False
.Cells(1, 1).AutoFilter field:=1, Criteria1:="Ｍ職" 'ユーザーフォームで指定
Set myR2 = .Range("B2", .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
For Each c In myR2
For i = 0 To UBound(myAry)
With Worksheets(myAry(i)) '4月から9月まで順に
j = Application.Match(c.Value, .Range("B:B"), 0)
If IsError(j) Then
MsgBox "その人のデータは、ありません": Exit Sub
Else
myTen1 = c.Offset(0, 2).Resize(1, 5).Value 'はじめの５つ
myTen2 = c.Offset(0, 7).Resize(1, 5).Value 'あとの５つ
With Worksheets("集計表")
.Cells(1, 1).Resize(1, 3).Value = c.Offset(0, -1) _
.Resize(1, 3).Value
.Cells(3, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = _
Application.Transpose(myTen1)
.Cells(9, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = _
Application.Transpose(myTen1)
End With
End If
End With
Next '次の月へ
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
Ans = MsgBox("印刷しますか？", vbYesNo)
If Ans = vbYes Then
MsgBox "印刷します" '実際は印刷処理
End If
Next '次の人へ
End Sub
|
|
ponpon
- 05/9/24(土) 21:40 -
