| |
こんばんは。
もう見てないかもしれませんが・・・
個人集計表に一応転記するところまで作ってみました。
エラー処理はしていません。
上級者には、笑われるかもしれませんが・・・・
もっと簡単で良い方法があったら、アドバイスしてください。
前提
今回は、４月から９月までの９枚のシートがあるものとし、
シートレイアウトは、提示されているものとします。
シート名は、全角の"４月"から"９月"
２０人位で試しましたが、人数が増えると時間がかかると思います。
PEN４2.6G、WinXPで1秒程度
以下コードです。試して見てください。
Sub test()
Dim myR As Range, myR2 As Range, c As Range
Dim myVal As Variant, myVal2 As Variant, SHNAME As Variant, myARy As Variant
Dim SH As Worksheet, NewSH As Worksheet
Dim Midasi As Variant
Dim i As Integer, j As Integer, t As Integer
Application.ScreenUpdating = False
'***************************************************
'月ファイル以外削除・・1回だけのの実施なら必要なし
'***************************************************
For Each SH In Worksheets
If SH.Index > 6 Then '4月から9月までの6枚のシートがあるとして、
Application.DisplayAlerts = False '7枚目以降は個人シート
SH.Delete 'だから削除
Application.DisplayAlerts = True
End If
Next
'*************************************************
'シート（４月）から氏名を抽出し、氏名シートの作成
'*************************************************
With Worksheets("４月")
'点数のところの見出しを格納
Midasi = .Cells(1, 4).Resize(1, 13).Value
'A1のCurrentRegionをmyRにセット
Set myR = .Range("A1").CurrentRegion
'myRを職種と、社員番号でソート
myR.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
"C2"), Order2:=xlAscending, Header:=xlGuess
'シート名になる氏名をSHNAMEに格納
SHNAME = .Range("B2", .Range("B65536").End(xlUp)).Value
'新しいシートを追加し、シート名を氏名にし、A2に「月」を
For t = 1 To UBound(SHNAME, 1) 'A3から下に点数の見出しを入れる。
Set NewSH = Worksheets.Add(after:=Sheets(Sheets.Count))
With NewSH
.Name = SHNAME(t, 1)
.Cells(2, 1).Value = "月"
.Cells(3, 1).Resize(10, 1).Value = Application.Transpose(Midasi)
End With
Next
End With
'***************************************
'シート４月から９月までデータの取り出し
'***************************************
myARy = Array("４月", "５月", "６月", "７月", "８月", "９月") '全角 シート名も全角で
For i = 0 To UBound(myARy)
'4月から順に9月のシートまで
With Worksheets(myARy(i))
'範囲をセットし、A列・C列でソート
Set myR = .Range("A1").CurrentRegion
myR.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
"C2"), Order2:=xlAscending, Header:=xlGuess
'A列を重複なしでAA列に書き出す。
myR.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AA1"), Unique:=True
'AA列の2行目から終わりまでをmyValに格納
myVal = .Range("AA2", .Range("AA65536").End(xlUp)).Value
'職種毎に
For j = 1 To UBound(myVal, 1)
'オートフィルターをかける
myR.AutoFilter field:=1, Criteria1:=myVal(j, 1)
'抽出されたB列をmyR2に格納
Set myR2 = .Range("B2", .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
' B列を上から順に
For Each c In myR2
'点数の部分だけをコピーして
c.Offset(0, 2).Resize(1, 10).Copy
'B列(氏名）と同じシートに
With Worksheets(c.Text)
'職種・氏名・社員番号の書き出し
If IsEmpty(.Cells(1, 1).Value) Then
.Cells(1, 1).Resize(1, 3).Value = c.Offset(0, -1).Resize(1, 3).Value
End If
'2行目に月名を入れて
.Cells(2, 256).End(xlToLeft).Offset(0, 1).Value = myARy(i)
'コピーしていた点数を行列を入れ替えて貼り付け
.Cells(3, 256).End(xlToLeft).Offset(0, 1).PasteSpecial Transpose:=True
End With
Next '次の人へ
'オートフィルターの解除
myR.AutoFilter
Next '次の職種へ
'一時利用したAA列の削除
.Range("AA:AA").ClearContents
End With
Next '次の月へ
'***************
'平均値の挿入
'***************
'月ファイルが6枚なので、Indexが７から終わりまでが個人シート
For t = 7 To Sheets.Count
'個人シートに
With Worksheets(t)
With .Cells(2, 256).End(xlToLeft)
'２行目の一番最後に「６ヶ月平均」を入力
.Offset(0, 1).Value = "６ヶ月平均"
'その下から10行に平均値を入力
.Offset(1, 1).Resize(10, 1).Value = "=AVERAGE(RC[-6]:RC[-1])"
End With
End With
Next
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
|
|
ponpon
- 05/9/22(木) 2:46 -
