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.1

fumufumu_2006 · ベストアンサー

こんなのでどうでしょうか？

>休みの種類は5種類あります。
というので、いくつでも対応できるようにしたつもりです。
Const restStr = "有：有休,公：公休,出：出勤" '抽出する文字と見出し
で追加してください。
質問の中で"："が全角になっていたので、全角でチェックしていますので、restStr内の"："は全角にしてください。
カンマ","は半角です。

Sub sample()
Const restStr = "有：有休,公：公休,出：出勤" '抽出する文字と見出し
Dim ss As Worksheet
Dim ds As Worksheet
Dim sr As Long
Dim sc As Integer
Dim dr As Long
Dim dc As Integer
Dim rest() As String
Dim i As Integer
Dim msg() As String
Set ss = Sheets("sheet1")
Set ds = Sheets("sheet2")
rest() = Split(restStr, ",")
ds.Cells.Clear
dr = 1
For i = 0 To UBound(rest)
msg = Split(rest(i), "：")
ds.Cells(dr, 1) = msg(1)
dr = dr + 1
For sc = 2 To ss.Cells(1, ss.Cells.Columns.Count).End(xlToLeft).Column
ss.Cells(1, sc).Copy Destination:=ds.Cells(dr, 1) '日付をコピー
dc = 2
For sr = 2 To ss.Cells(ss.Cells.Rows.Count, sc).End(xlUp).Row
If ss.Cells(sr, sc) = msg(0) Then
ds.Cells(dr, dc) = ss.Cells(sr, 1)
dc = dc + 1
End If
Next
dr = dr + 1
Next
dr = dr + 1
Next
End Sub

お礼

遅くなりましたありがとうございます。
いい感じに集計できました。
助かりました。

回答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

お礼

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