エクセルで複数行のデータを1列にまとめたい

エクセルのデータで

　　　Ａ　　　　　Ｂ　　　Ｃ　　　 Ｄ　　　 Ｅ　　　Ｆ　　　　Ｇ　　　Ｈ　　　　Ｉ
1 氏名　 　　　項目① 　金額　 項目②　　金額　　項目③　 金額　　項目④　　金額
2　鈴木太郎　　　　　　　　　　　　　　　　　　　　雑費　　　10　　　　　　　　　　　　　　3　松本次郎　　　　　　　　　　　　　　　　　　　　　　　　　　　　 その他　　　5
4　鈴木太郎　　 給与　　　50　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 5　大手三郎　　　　　　　　　　　交通費　　 30　　　　　　　　　　　　　　　　　　　　　　　6　鈴木太郎　　　　　　　　　　　　　　　　　　　　　　　　　　　　 その他　　 10　　　 7　松本次郎　　 給与　　 40

といったデータを、下記のようにまとめたいと思っています。

　　　Ａ　　　　　Ｂ　　　 Ｃ　　　　Ｄ　　　　Ｅ　　　　Ｆ　　　 Ｇ　　　　Ｈ　　　　Ｉ
　 氏名　 　　　項目① 　金額　 項目②　　金額　　　項目③　　金額　　　項目④　　金額
　 鈴木太郎　　　給与　　　50　　　　　　　　　　　　 雑費　　　10　　　その他　　 10　　
　 松本次郎　　　給与　　　 40　　　　　　　　　　　　　　　　　　　　　　 その他　　 5
　 大手三郎 交通費　　30

というように、名前ごとで複数の項目を1行にまとめたいのですが、どのようにしたらまとめることができるでしょうか。
２０００件近くあるデータを名寄せし、コピペしながら1行にしようかと思っていたのですが、もっと効率よく正確にまとめられたらと思っております。

宜しくお願い致します。

質問者からの補足コメント

• 質問の際にはずれていなかったのですが、投稿した際にずれてしまったようで、分かりずらくすみません。

  No.2の回答に寄せられた補足コメントです。 補足日時：2015/12/15 23:35

No.3 ベストアンサー 回答者： 30246kiku 回答日時： 2015/12/15 17:22

以下でどうでしょうか

Public Sub Samp1()
　　Dim dic As Object, dicE As Object
　　Dim vA As Variant, vK As Variant, v As Variant
　　Dim i As Long, j As Long

　　Set dic = CreateObject("Scripting.Dictionary")
　　Set dicE = CreateObject("Scripting.Dictionary")

　　With ActiveSheet
　　　　vA = Intersect(.Range("A1").CurrentRegion, .Range("A:I")).Value
　　End With
　　For i = 2 To UBound(vA)
　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　dic.Add vA(i, 1), CreateObject("Scripting.Dictionary")
　　　　End If
　　　　For j = 2 To UBound(vA, 2) Step 2
　　　　　　If (vA(i, j) <> "") Then
　　　　　　　　dic(vA(i, 1))(vA(i, j)) = _
　　　　　　　　　　dic(vA(i, 1))(vA(i, j)) + vA(i, j + 1)
　　　　　　　　dicE(vA(i, j)) = Empty
　　　　　　End If
　　　　Next
　　Next

　　If (dic.Count > 0) Then
　　　　ReDim vA(1 To dic.Count + 1, 1 To dicE.Count + 1)
　　　　vA(1, 1) = "氏名"
　　　　v = mySort(dicE.Keys)
　　　　For i = 0 To UBound(v)
　　　　　　j = i + 2
　　　　　　vA(1, j) = v(i)
　　　　　　dicE(v(i)) = j
　　　　Next

　　　　i = 2
　　　　For Each vK In mySort(dic.Keys)
　　　　　　vA(i, 1) = vK
　　　　　　For Each v In dic(vK).Keys
　　　　　　　　vA(i, dicE(v)) = dic(vK)(v)
　　　　　　Next
　　　　　　i = i + 1
　　　　Next

　　　　Worksheets.Add
　　　　Range("A1").Resize(UBound(vA), UBound(vA, 2)).Value = vA
'　　　　Columns.AutoFit
　　End If

　　Set dic = Nothing
　　Set dicE = Nothing
End Sub

Private Function mySort(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, j As Long

　　For i = 0 To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (vA(i) > vA(j)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySort = vA
End Function

No.4 回答者： mike_g 回答日時： 2015/12/17 19:46

関数やフィルタ等での実現は難しそうですね。

手動でやるなら、まれチャンお得意の単純な「地道にコツコツ」しかなさそう。
単純なら、マクロにお縋りすべきですね。
ただし、私はマクロ音痴なので此処でサヨナラです。

No.2 回答者： mike_g 回答日時： 2015/12/15 16:41

「大手三郎」のデータだけは、他と違って、なぜ左方向へ移動しているのですか？

この回答へのお礼

ご丁寧にありがとうございました‼︎

初心者ながは若干アレンジしつつ、できました。

お礼日時：2015/12/20 20:13

No.1 回答者： zircon3 回答日時： 2015/12/15 10:34

別シート（集計シート）を追加し、そこに名前をキーにして現シートの内容を１名１行でデータを入れて行くマクロを作成すればよいと思います。

大まかには以下のような感じです。見出し行があるとか、現シートのA列は通し番号だが、集計結果にはそれは不用とか、そういった細かな事はご自身でお考えください。

(1) 準備として集計シートを作成しておく
(2) 現シートの1行目からA列が空欄となるまで以下の処理を行うマクロを作成する。マクロの起動は集計シート状に設ける「集計」ボタンで行う。
　[前提]現シートのデータ行間に空行は無い
　1)名前を取り出し集計シートのA列に同名を探す。無い場合は最終行に名前を追加
　2)原稿シートの該当行の各列のうち、値が入ったセル（空ではないセル）の内容を集計シートの1)で探した行の同じ列のセルにコピーする。