[[20180611105541]]　『リスト一括変換につきまして』（飛翔鯨）　ページの最後に飛ぶ

『リスト一括変換につきまして』（飛翔鯨）

お世話になっております。
VBA初心者です。宜しくご教授下さい。

	A	B	C
	name	rank	stage
1	a	AA	1
2	b	AB	1
3	c	AA	5
4	d	AC	4
5	e	AB	2
6	f	AA	1
7	g	AD	1

・
・
・

というリストがあります。これを下記のように
VBAにより一括変換したいのです。

	rank			
stage	AA	AB	AC	AD
1	a	b		g
	f			
2		e		
3				
4			d	
5	c

・
・
・

これをなんというのか。。。
マトリクス変換と言うのでしょうか、このような変換ができるコードをお教え下さい。

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

まずはご自分で考えて欲しいです。コーディングができないならば、ピボットテーブルで済ますとか、自分でできる範囲でなんとかすべき。

とりあえずサンプルを書きますが、項目をソートしておきながら、stageには重複があるとか、とても面倒なデータとレイアウトなので、コーディングしやすい出力レイアウトに変えています。これが駄目ならば、ご自身で全部考えてください。それでも、考え方の参考くらいにはなるでしょう。

 Sub test()
    Dim AR As Object
    Dim DICX As Object
    Dim DICY As Object
    Dim wk1 As Worksheet
    Dim wk2 As Worksheet
    Dim cw As String
    Dim i As Long

    Set AR = CreateObject("System.Collections.ArrayList")
    Set DICX = CreateObject("Scripting.Dictionary")
    Set DICY = CreateObject("Scripting.Dictionary")
    Set wk1 = Sheets("Sheet1")
    Set wk2 = Sheets("Sheet2")

    wk2.Cells.ClearContents

    AR.Clear
    For i = 2 To wk1.Cells(wk1.Rows.Count, "B").End(xlUp).Row
        cw = wk1.Cells(i, "B").Text
        If Not AR.Contains(cw) Then
            AR.Add cw
        End If
    Next i
    AR.Sort
    wk2.Range("B1").Resize(1, AR.Count) = AR.toarray
    For i = 0 To AR.Count - 1
        DICX.Add AR(i), i + 2
    Next i

    AR.Clear
    For i = 2 To wk1.Cells(wk1.Rows.Count, "C").End(xlUp).Row
        cw = wk1.Cells(i, "C").Text
        If Not AR.Contains(cw) Then
            AR.Add cw
        End If
    Next i
    AR.Sort
    wk2.Range("A2").Resize(AR.Count, 1) = WorksheetFunction.Transpose(AR.toarray)
    For i = 0 To AR.Count - 1
        DICY.Add AR(i), i + 2
    Next i

    For i = 2 To wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row
        wk2.Cells(DICY(wk1.Cells(i, "C").Text), DICX(wk1.Cells(i, "B").Text)) = Trim(wk2.Cells(DICY(wk1.Cells(i, "C").Text), DICX(wk1.Cells(i, "B").Text)) & " " & wk1.Cells(i, "A").Value)
    Next i
 End Sub
（???） 2018/06/11(月) 11:46

例えば・・・・

Option Explicit

Sub List2Matrix()

    Dim rngOld As Range
    Dim rngNew As Range
    Dim rngTmpe As Range
    Dim ixMax As Long
    Dim ixCol As Long
    Dim ixRow As Long
    Dim c As Range

    Set rngOld = Worksheets("Sheet3").Range("A1").CurrentRegion
    Set rngTmpe = Worksheets("Sheet4").Range("A1")

    '表頭の作成
    rngOld.Columns(2).Copy rngTmpe
    With rngTmpe.CurrentRegion
        .RemoveDuplicates Columns:=1, Header:=xlYes
        .Copy
        .Cells(2, 2).PasteSpecial Transpose:=True
    End With
    '表側の作成
    ixMax = WorksheetFunction.Max(rngOld.Columns(3))
    With rngTmpe(3, 2)
        .Cells(1).Value = 1
        .Resize(ixMax).DataSeries Step:=1, Stop:=ixMax
    End With
    rngTmpe.EntireColumn.Delete
    '作成したマトリックス表のセル範囲の取得
    With Worksheets("Sheet4").Range("A2").CurrentRegion
        Set rngNew = Intersect(.Cells, .Offset(1, 1))
    End With

    '転記する名前のセル範囲
    With rngOld
        Set rngTmpe = Intersect(.Columns(1), .Offset(1))
    End With
    'マトリックス表へ転記
    For Each c In rngTmpe
        With WorksheetFunction
            ixCol = .Match(c.Offset(, 1), rngNew.Rows(0), 0)
            ixRow = .Match(c.Offset(, 2), rngNew.Columns(0), 0)
        End With
        With rngNew(ixRow, ixCol)
            If Len(.Value) > 0 Then
                .Value = .Value & "・" & c.Value
            Else
                .Value = c.Value
            End If
        End With
    Next
End Sub
（まっつわん） 2018/06/11(月) 13:25

???様、まっつわん様、誠に有難うございました！
大変参考になりました！
（飛翔鯨） 2018/06/12(火) 14:12

コメント返信：

[ 一覧(最新更新順) ]

[[20180611105541]] 『リスト一括変換につきまして』（飛翔鯨） ページの最後に飛ぶ

[[20180611105541]]　『リスト一括変換につきまして』（飛翔鯨）　ページの最後に飛ぶ