VBAを用いて、行と列を入れ替えた表を別シートに抽出する方法について

Question

解決したいこと

マクロVBAを用いて、別シートに行と列を入れ替えた表（表Bのような形）を作成したいです。
元データは、表Aのような形式です。

発生している問題・エラー

一度に全種類のIDに対して、名前を横並びに表示できるようにしたいのですが、自分が思いついた方法は、別シート上で、特定のIDの名前だけを横一列に並べ、そのほかのIDのデータは消去する、という流れだけなので、困っています。

手元にある表Aから、別シートに表Bを抽出させるようなマクロVBAの記述方法をご存じのかたがいらっしゃいましたら、教えていただきたいです。

（表A）

（表B）

（現状0）

(現状1）

（現状2）

（現状3）

※追記
マルチポストをする理由について
最初、Qiita にて質問したところ、質問投稿が完了した後に、質問が削除されて閲覧できなくなっていました。Qiitaでもう一度質問を再投稿したものの、また知らないうちに質問が削除されると困るので、こちらのサイトでも質問してしまいました。
マルチポストについて教えてくださり、ありがとうございました。

別の投稿先のリンク
https://qiita.com/Yukimiooo/questions/0df58337d8a059b0ba7a

Comments

[radames1000]

マルチポストについての記載をご確認ください。
https://teratail.com/help#posted-otherservice

[Yukimiooo]

マルチポストについての規約を知りませんでした。
丁寧に教えていただき、ありがとうございました。
マルチポストをする理由と、ほかのサイトのリンクを、質問内容に加筆いたします。

Answer 1

シート：データ　の内容を読み込み、
シート：理想　へ出力します。理想の１行目に見出しは、マクロでは設定しません。

Option Explicit
Public Sub sample()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim dicT As Object
    Dim maxrow As Long
    Dim wrow As Long
    Dim key As Variant
    Set sh1 = Worksheets("データ")
    Set sh2 = Worksheets("理想")
    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    maxrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row '最終行を求める
    For wrow = 2 To maxrow
        key = sh1.Cells(wrow, 1).Value
        If dicT.exists(key) = False Then
            dicT(key) = sh1.Cells(wrow, 2).Value
        Else
            dicT(key) = dicT(key) & "," & sh1.Cells(wrow, 2).Value
        End If
    Next
    sh2.Rows("2:" & Rows.Count).ClearContents       '2行目以降をクリア
    wrow = 2
    For Each key In dicT
        sh2.Cells(wrow, 1).Value = key
        sh2.Cells(wrow, 2).Value = dicT(key)
        wrow = wrow + 1
    Next
End Sub

Comments

[Yukimiooo]

コメントも丁寧に書いてくださり、初心者の私でも、コードの意味がわかりやすかったです。ありがとうございます。