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

質問・疑問に答えるQ&AサイトOKWave

OKWave

[ 詳しく ]

FAQ（よくある質問）

法人向けサービス

質問する

○○だけど・・・？

解決済みの質問

Check

印刷

<< 前の質問 | 次の質問 >>

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で挑戦したいと考えておりましたが、あえなく挫折してしまいました。

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

投稿日時 - 2010-09-04 22:45:19

連想キーワード：

通報する

QNo.6159021

fuwa_toshiharu

すぐに回答ほしいです

ブックマーク

質問者が選んだベストアンサー

こんにちわ

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

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