Yukimiooo
@Yukimiooo (Yukimi Ooo)

Are you sure you want to delete the question?

If your question is resolved, you may close it.

Leaving a resolved question undeleted may help others!

We hope you find it useful!

マクロVBAを用いて、別シートに、行と列を入れ替えた表を作成する方法

解決したいこと

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

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

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

(表B)
理想形.png

(現状0)
現状0.png

(現状1)
現状1.png

(現状2)
現状2.png

(現状3)
現状3.png

0

1Answer

いろいろなやり方があると思いますが、
たとえばこんな感じで考えてみたらどうでしょうか。

Sub main()
    '準備
    Dim データ As Worksheet, 抽出 As Worksheet
    Set データ = Sheets("データ")
    Set 抽出 = Sheets("抽出")
    データ.AutoFilterMode = False
    抽出.Cells.Clear
    
    'まず抽出シートにコピー
    データ.UsedRange.Copy 抽出.Cells(1, 1)
    
    '抽出シートのID列の重複を削除
    抽出.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    
    Dim ID範囲 As Range
    Set ID範囲 = 抽出.UsedRange.Resize(抽出.UsedRange.Rows.Count - 1, 1).Offset(1)
    
    '抽出シートをID列で並べ替え
    With 抽出.Sort
        .SortFields.Clear
        .SortFields.Add ID範囲
        .SetRange ID範囲
        .Header = xlNo
        .Apply
    End With
    
    Dim IDセル As Range, 名前セル As Range, 結合文字 As String
    Dim 名前範囲 As Range
    Set 名前範囲 = データ.UsedRange.Resize(データ.UsedRange.Rows.Count - 1, 1).Offset(1, 1)
    
    '抽出シートのID列の値で順番に処理
    For Each IDセル In ID範囲
        
        'データシートをIDの値で絞り込み
        データ.UsedRange.AutoFilter Field:=1, Criteria1:=IDセル.Value
        '表示されている行を順番に処理
        For Each 名前セル In 名前範囲.SpecialCells(xlCellTypeVisible)
            結合文字 = 結合文字 & 名前セル.Text & ","
        Next 名前セル
        
        '抽出シートの名前列にセット
        IDセル.Offset(, 1).Value = 結合文字
        
        'WK変数クリア
        結合文字 = ""
    
    Next IDセル
        
    '後始末
    データ.AutoFilterMode = False

End Sub

あと、個人的にはこんなのが好み。

Sub main()
    Dim d, c, v
    With Sheets("抽出")
        .Cells.Clear
        Set d = CreateObject("Scripting.Dictionary")
        For Each c In Sheets("データ").UsedRange.Resize(, 1)
            d(c.Value) = d(c.Value) & c.Offset(, 1).Value & ","
        Next
        Set v = .Cells.Resize(d.Count, 2)
        v.Value = WorksheetFunction.Transpose(Array(d.Keys, d.Items))
        With .Sort
            .SortFields.Clear
            .SortFields.Add v.Resize(, 1)
            .SetRange v
            .Apply
        End With
    End With
End Sub
0Like

Comments

  1. @Yukimiooo

    Questioner

    コメント入りのコード、洗練されたコード、二通り示してくださり、ありがとうございます。コメント入りのコードのおかげで、初心者の私でも、理解が進みました。また、洗練されたコードを見て、早くこういう風に書けるようになりたいというモチベーションも上がりました。ありがとうございました。

Your answer might help someone💌