[[20211204184259]]　『１列のデータを規約ごとに複数列に分ける』（かず）　ページの最後に飛ぶ

『１列のデータを規約ごとに複数列に分ける』（かず）

初めまして．質問があります．
「シート1」
A社 a1
A社 a2
A社 a3
A社 a4
B社 b1
B社 b2
B社 b3
C社 c1
D社 d1
D社 d2
D社 d3
D社 d4

↓

「シート２」
A社　B社　C社　D社
a1　　b1　　c1　 d1
a2　　b2　　　　d2
a3　　b3　　　　 d3
a4 　　　　　　　d4

このように，シート１の2列にデータを並べた時にシート２に自動的に反映されるように関数を作りたいんですけど，どのように作ればよいでしょうか？関数は，シート２のa1などに入力できればと思っています．所々ずれていてみにくく申し訳ありません．シート２には，A社列にaのデータ，B社列にbのデータを入力したいです．
もし関数が難しければ，マクロでも構いません．できる方は，よろしくお願いします．

＜使用 Excel：unknown、使用 OS：unknown ＞

 関数やPowerQueryでも出来ると思いますが、不得手ですのでとりあえずマクロです。
 そちらの回答は他の方の回答をお待ち下さい。

 Sub Macro1()
    Dim dic As Object
    Dim ts As Worksheet
    Dim i As Long, j As Long
    Dim cnt As Long
    Dim arr
    Set dic = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")
        For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            On Error Resume Next
            dic.Add .Cells(i, 1).Value, ""
            On Error GoTo 0
        Next i
        arr = Range(.Cells(1, 1), .Cells(Rows.Count, 2).End(xlUp)).Value
        Set ts = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ts.Cells(1, 1).Resize(, UBound(dic.keys) + 1).Value = dic.keys
        For i = 1 To UBound(dic.keys) + 1
            cnt = 1
            For j = 1 To UBound(arr)
                If arr(j, 1) = ts.Cells(1, i).Value Then
                    cnt = cnt + 1
                    ts.Cells(cnt, i).Value = arr(j, 2)
                End If
            Next j
        Next i
    End With
 End Sub
（MixNuts） 2021/12/04(土) 21:44

 シートの名前は、
 With Worksheets("Sheet1")　の"Sheet1" を実際のシート名に書き直して下さい。
 例)シート1だとしたら、With Worksheets("シート1") の様に。
（MixNuts） 2021/12/04(土) 21:47

 参考に
 Sub Test()
    Dim myDic As Object
    Dim v() As String, c As Range, d As Variant
    Dim key As String, itm As String, i As Long, rng As Range

    Set myDic = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")
        For Each c In .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
            key = Split(c.Value)(0)
            itm = Split(c.Value)(1)
            If myDic.Exists(key) Then
                v = myDic(key)
                i = UBound(v) + 1
                ReDim Preserve v(i)
            Else
                i = 0
                ReDim v(i)
            End If
            v(i) = itm
            myDic(key) = v
        Next
    End With
    Set rng = Worksheets("Sheet2").Range("A1")
    For Each d In myDic.keys
        rng.Value = d
        rng.Offset(1).Resize(UBound(myDic(d)) + 1).Value = Application.Transpose(myDic(d))
        Set rng = rng.Offset(, 1)
    Next
 End Sub

（ピンク） 2021/12/04(土) 22:29

 >１列のデータを規約ごとに複数列に分ける
 A列1列に "A社 a1" と記述しているのではなく

 A列  B列
 A社  a1

 なら私の早とちりで間違った回答をしてしまったようです。(;^_^A
 今日は絶不調なので寝ます。

（ピンク） 2021/12/04(土) 22:54

 A列  B列
 A社  a1   の方も回答しておきます。

 Sub Test2()
    Dim myDic As Object
    Dim v() As String, c As Range, d As Variant
    Dim i As Long, rng As Range

    Set myDic = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")
        For Each c In .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
            If myDic.Exists(c.Value) Then
                v = myDic(c.Value)
                i = UBound(v) + 1
                ReDim Preserve v(i)
            Else
                i = 0
                ReDim v(i)
            End If
            v(i) = c.Offset(, 1).Value
            myDic(c.Value) = v
        Next
    End With
    Set rng = Worksheets("Sheet2").Range("A1")
    For Each d In myDic.keys
        rng.Value = d
        rng.Offset(1).Resize(UBound(myDic(d)) + 1).Value = Application.Transpose(myDic(d))
        Set rng = rng.Offset(, 1)
    Next
 End Sub
（ピンク） 2021/12/04(土) 23:00

 A1: =TRANSPOSE(FILTER(UNIQUE(Sheet1!A:A),UNIQUE(Sheet1!A:A)<>""))
 A2: =IF(A$1<>"",FILTER(Sheet1!$B:$B,Sheet1!$A:$A=A$1),"")

（マナ） 2021/12/04(土) 23:07

 おはようございます。
365難民の私が何を思ったのか証拠にもなく思い付きで書いてみました。(^^;

 A1に↓として右にフィル
=IFERROR(INDEX(Sheet1!$A$1:$A$12,
AGGREGATE(15,6,(MATCH(Sheet1!$A$1:$A$12,Sheet1!$A$1:$A$12,0)=ROW($A$1:$A$12))/(MATCH(Sheet1!$A$1:$A$12,Sheet1!$A$1:$A$12,0)=ROW($A$1:$A$12))*ROW($A$1:$A$12),COLUMN(A1))),"")

 A2に↓として右に下にフィル
=IFERROR(INDEX(Sheet1!$B$1:$B$12,
AGGREGATE(15,6,(((Sheet1!$A$1:$A$12=A$1)*ROW($A$1:$A$12))/((Sheet1!$A$1:$A$12=A$1)*ROW($A$1:$A$12)))*ROW($A$1:$A$12),ROW(A1))),"")
（SoulMan） 2021/12/05(日) 08:06

EXCEL2010(?)以降として書き込みます。

Sheet2の1行目に会社名が入力されているとします。

A2: =IFERROR(INDEX(Sheet1!$B$1:$B$12,AGGREGATE(15,6,ROW($A$1:$A$12)/(Sheet1!$A$1:$A$12=A$1),ROW(A1))),"")

右と下にコピーします。
（メジロ） 2021/12/05(日) 09:45

コメント返信：

[ 一覧(最新更新順) ]

[[20211204184259]] 『１列のデータを規約ごとに複数列に分ける』（かず） ページの最後に飛ぶ

[[20211204184259]]　『１列のデータを規約ごとに複数列に分ける』（かず）　ページの最後に飛ぶ