Excelマクロで教えて下さい。

質問

Excelマクロで教えて下さい。
シート1に下記のような表がありまして
その表の有休・公休取得者の名前を日にち別に
シート2にまとめたいのですがマクロを教えて下さい。
・日にちは3ヶ月並びます。
・人数は50人います。
・休みの種類は5種類あります。
・有：有休　公：公休　出：出勤(本来は空欄です)　
表の入力が難くわかり難いですが宜しく御願い致します。
シート1
名前 3/1 3/2 3/3 3/4 3/5
A氏 出 有 有 出 出
B氏 有 有 出 公 出
C氏 出 出 有 有 出
D氏 出 有 出 出 有
E氏 有 出 出 有 公

シート2
有休
3/1 B氏 E氏
3/2 A氏 B氏 D氏
3/3 A氏 C氏
3/4 C氏 E氏
3/5 D氏

公休
3/1
3/2
3/3
3/4 B氏
3/5 E氏

回答No.2

Wendy02

こんばんは。

私もちょっと考えてみましたが、位置関係が狂うと、まったくダメになってしまうような、微妙な感じのマクロです。一回、作ったら、もう修正の利かない種類です。

'---------------------------------------
'標準モジュール
'---------------------------------------
Sub TestMarco1()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim i As Long, j As Long, k As Integer
　　Dim x As Integer, y As Integer, z As Integer
　　Dim n As Long, m As Long
　　Dim buf As Variant
　　Dim clm As Integer
　　Dim rw As Long
　　Dim dTypes As Variant
　　Dim dTitles As Variant
　　Dim Cntnt() As Variant
　　Dim SpNames() As Variant
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　'有: 有休 公: 公休 出: 出勤 (本来は空欄です)
　　'順番を変えるのはここでします。

　　dTitles = Split("有休,公休,出勤,早出,遅出", ",")
　　dTypes = Split("有,公,出,早,遅", ",")

　　rw = sh1.Range("A65536").End(xlUp).Row '下限
　　clm = sh1.Range("IV1").End(xlToLeft).Column '右端

　　ReDim SpNames(UBound(dTypes))

　　sh2.Cells.Clear
　　'日付のコピー
　　x = 1 'グループごとのすき間
　　For y = 0 To 1　'UBound(dTitles)　''本来は全部出す
　　　　sh2.Range("A1").Offset(clm * y + x - 1).Value = dTitles(y)
　　　　sh1.Range("B1").Resize(, clm).Copy
　　　　sh2.Range("A1").Offset(clm * y + x).PasteSpecial , , , True
　　Next y
　　Application.CutCopyMode = False
　　Application.ScreenUpdating = False
　　For n = 2 To clm '列
　　　　For m = 2 To rw '行
　　　　　　With sh1
　　　　　　　　If .Cells(m, n).Value = "" Then
　　　　　　　　　　'出勤
　　　　　　　　　　k = 3 '検索値
　　　　　　　　Else
　　　　　　　　　　k = Application.Match(Trim(.Cells(m, n).Value), dTypes, 0)
　　　　　　　　End If
　　　　　　　　If Not IsError(k) And k <> 3 Then　'出勤は出力しない
　　　　　　　　　　SpNames(k - 1) = SpNames(k - 1) & "," & .Cells(m, 1).Value
　　　　　　　　End If
　　　　　　End With
　　　　Next m

　　　　For z = 0 To UBound(SpNames())
　　　　　　buf = Split(Mid(SpNames(z), 2), ",")
　　　　　　If UBound(buf) > -1 Then
　　　　　　　　'(右端 - データ左端 + 間行)*Z + 先の行
　　　　　　　　sh2.Cells((clm - 1 + x) * z + n, 2).Resize(, UBound(buf) + 1).Value _
　　　　　　　　= buf
　　　　　　End If
　　　　Next z
　　　　Erase buf
　　　　ReDim SpNames(UBound(dTypes))
　　Next n
　　Application.ScreenUpdating = True
　　Set sh1 = Nothing: Set sh2 = Nothing
End Sub

お礼

遅くなりましたありがとうございます。
今後マクロの組み方の参考にさせて頂きます。