|
こんばんは。
仕様にいろいろ制約があるようで、私にはちょっと難しいようです。
集計表が以下のようだとして
A B C D E F G H
1
2 月 4月 5月 6月 7月 8月 9月 6ヶ月平均
3 点数A #DIV/0!
4 点数B #DIV/0!
5 点数C #DIV/0!
6 点数D #DIV/0!
7 点数E #DIV/0!
8 月 4月 5月 6月 7月 8月 9月 6ヶ月平均
9 点数F #DIV/0!
10点数G #DIV/0!
11点数H #DIV/0!
12点数I #DIV/0!
13点数J #DIV/0!
職種や氏名や社員番号ををユーザーフォームで指定するなら
以下のようになると思います。試してください。
こちらでは、きちんと書き出されています。
Sub test()
Dim myR2 As Range, c As Range
Dim myAry As Variant
Dim i As Integer, j As Integer
Dim Ans
Application.ScreenUpdating = False
'***************************************
'シート4月から9月までデータの取り出し
'***************************************
myAry = Array("4月", "5月", "6月", "7月", "8月", "9月") '全角 シート名も全角で
For i = 0 To UBound(myAry)
'4月から順に9月のシートまで
With Worksheets(myAry(i))
'オートフィルターをかける
.Cells(1, 1).AutoFilter field:=1, Criteria1:="s職" 'ユーザーフォームで指定
'抽出されたB列をmyR2に格納
Set myR2 = .Range("B2", .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
j = Application.Match("佐藤", .Range("B:B"), 0) 'ユーザーフォームで指定
If IsError(j) Then
MsgBox "その人のデータは、ありません": Exit Sub
Else
Set c = .Cells(j, 2)
'点数の部分だけをコピーして
myTen1 = c.Offset(0, 2).Resize(1, 5).Value 'はじめの5つ
myTen2 = c.Offset(0, 7).Resize(1, 5).Value 'あとの5つ
'B列(氏名)と同じシートに
With Worksheets("集計表")
'職種・氏名・社員番号の書き出し
.Cells(1, 1).Resize(1, 3).Value = c.Offset(0, -1).Resize(1, 3).Value
'コピーしていた点数を行列を入れ替えて貼り付け 5つずつ
.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
'オートフィルターの解除
.AutoFilterMode = False
End With
Next '次の月へ
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
Ans = MsgBox("印刷しますか?", vbYesNo)
If Ans = vbYes Then
MsgBox "印刷します" '実際は印刷処理
End If
End Sub
|
|