マクロVBAを用いて、別シートに、行と列を入れ替えた表を作成する方法
解決したいこと
マクロVBAを用いて、別シートに行と列を入れ替えた表(表Bのような形)を作成したいです。
元データは、表Aのような形式です。
発生している問題・エラー
一度に全種類のIDに対して、名前を横並びに表示できるようにしたいのですが、自分が思いついた方法は、別シート上で、特定のIDの名前だけを横一列に並べ、そのほかのIDのデータは消去する、という流れだけなので、困っています。
(表A)
0
マクロVBAを用いて、別シートに行と列を入れ替えた表(表Bのような形)を作成したいです。
元データは、表Aのような形式です。
一度に全種類のIDに対して、名前を横並びに表示できるようにしたいのですが、自分が思いついた方法は、別シート上で、特定のIDの名前だけを横一列に並べ、そのほかのIDのデータは消去する、という流れだけなので、困っています。
(表A)
いろいろなやり方があると思いますが、
たとえばこんな感じで考えてみたらどうでしょうか。
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
@Yukimiooo
Questioner