Excel VBA 営業日報・横表示を縦表示にしたい！

質問

Excel VBA　営業日報・横表示を縦表示にしたい！

非常に困っており、皆様のお知恵を拝借したいと存じます。
現在、横方向に展開している営業日報を、縦方向に展開するにはどのようにすればよいでしょうか？Excel VBAで実現したいと考えております。

(1)現在の横方向の営業日報

勤務年月　所属名　 社員番号　氏名　　　　労働時間
2010.01　 営業1課　　001　　 鈴木一郎　　　10.0
2010.01　 営業1課　　002　　 山田二郎　　　11.0
2010.01　 営業1課　　003　　 佐藤三郎　　　12.0

2010.02　 営業1課　　001　　 鈴木一郎　　　10.0
2010.02　 営業1課　　003　　 佐藤三郎　　　12.0

2010.03　 営業1課　　001　　 鈴木一郎　　　10.0
2010.03　 営業1課　　003　　 佐藤三郎　　　12.0

2010.03　 営業2課　　002　　 山田二郎　　　11.0

(2)作成したい縦方向の営業日報

所属名　　社員番号　氏名　　　2010.01　　2010.02　　2010.03
営業1課　　001　　　鈴木一郎　　10.0　　　10.0　　　　10.0
営業1課　　002　　　山田二郎　　11.0　　　－　　　　　－
営業1課　　003　　　佐藤三郎　　12.0　　　12.0　　　　12.0

営業2課　　002　　　山田二郎　　－　　　　－　　　　　11.0

各課の人員が必ず固定であれば良いのですが、ここで問題となってくるのは、各課の人員は異動や新入社員の加入によって人員が変動するということです。
上記(1)→(2)の例は、2010.01まで営業1課に所属していた山田二郎が、2010.02に休職し、2010.03から営業2課に配属になったケースです。
所属していない、あるいは休職していた月は「－」で表示する仕様です。

このようなケースの場合、ピボットテーブルを活用すれば問題が解決することは私も知ってはいるのですが、今回は後学のためもあり、VBAで挑戦したいと考えておりましたが、あえなく挫折してしまいました。

今回の問題を解決する手法をご教授いただければ幸いです。

回答No.1

ki-aaa · ベストアンサー

こんにちわ

Sub test()
Dim gyo As Long, max_gyo As Long
Dim retu As Long, max_retu As Long
Dim j As Long, k As Long
Dim key As String

Sheets("Sheet2").Select
Cells.ClearContents

Range("A1") = "key"
Sheets("Sheet1").Range("B1:D1").Copy Range("B1")
max_gyo = 1
max_retu = 4

For j = 2 To Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
If Sheets("Sheet1").Range("A" & j) <> "" Then
key = Sheets("Sheet1").Range("B" & j) & _
Sheets("Sheet1").Range("C" & j) & _
Sheets("Sheet1").Range("D" & j)

On Error Resume Next
gyo = Application.WorksheetFunction.Match _
(key, Columns("A"), 0)
If Err.Number <> 0 Then
gyo = max_gyo + 1
max_gyo = gyo
Range("A" & gyo) = key
Sheets("Sheet1").Range("B" & j & ":D" & j).Copy Range("B" & gyo)
End If
On Error GoTo 0

On Error Resume Next
retu = Application.WorksheetFunction.Match _
(Sheets("Sheet1").Range("A" & j).Value, Rows(1), 0)
If Err.Number <> 0 Then
retu = max_retu + 1
max_retu = retu
Sheets("Sheet1").Range("A" & j).Copy Cells(1, retu)
End If
On Error GoTo 0
Sheets("Sheet1").Range("E" & j).Copy Cells(gyo, retu)
End If
Next j
End Sub

それから、作業列の削除、空白セルにーをいれる、所属部署が変わったときに空白行を追加するは自分でやるようお願いします。

お礼

ki-aaa様

返事が遅れまして大変申し訳ありません。
私の拙い質問のためにわざわざコードを提供いただき、心より感謝申し上げます。
現在のいただいたコードをもとに格闘中です。結果はまた報告させていただきます。