| |
こんばんは。
仕様にいろいろ制約があるようで、私にはちょっと難しいようです。
集計表が以下のようだとして
A B C D E F G H
1
2 月 ４月 ５月 ６月 ７月 ８月 ９月 ６ヶ月平均
3 点数A #DIV/0!
4 点数B #DIV/0!
5 点数C #DIV/0!
6 点数D #DIV/0!
7 点数E #DIV/0!
8 月 ４月 ５月 ６月 ７月 ８月 ９月 ６ヶ月平均
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
'***************************************
'シート４月から９月までデータの取り出し
'***************************************
myAry = Array("４月", "５月", "６月", "７月", "８月", "９月") '全角 シート名も全角で
For i = 0 To UBound(myAry)
'4月から順に9月のシートまで
With Worksheets(myAry(i))
'オートフィルターをかける
.Cells(1, 1).AutoFilter field:=1, Criteria1:="ｓ職" 'ユーザーフォームで指定
'抽出された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 'はじめの５つ
myTen2 = c.Offset(0, 7).Resize(1, 5).Value 'あとの５つ
'B列(氏名）と同じシートに
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
'オートフィルターの解除
.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
|
|
ponpon
- 05/9/24(土) 0:23 -
