[[20200514161450]]　『クロス集計の逆の表を作る方法』（Ｙ）　ページの最後に飛ぶ

『クロス集計の逆の表を作る方法』（Ｙ）

皆様のお知恵を貸してください。

膨大なデータを縦横で整理するときには、数字の集計の場合はピボットテーブルを使えばいろいろできると思いますが、文字列をそのまま表に残したい場合どうすればいいのか、教えてください。

具体的には、例えば、元データが

入社　　ポジション　　氏名
2011　　係長　　　　　Ａ
2011　　係長　　　　　Ｂ
2012　　課長　　　　　Ｃ
2012　　係長　　　　　Ｄ
2012　　課長　　　　　Ｅ

というデータだったとします。このとき、完成形を
縦軸に入社、横軸にポジション、中身は氏名という風にしてつくりたいです。
イメージは、

　　　課長　　係長
2011　　　　　Ａ
2011　　　　　Ｂ
2012　Ｃ
2012　Ｅ
2012　　　　　Ｄ

もっと言うと

　　　課長　　係長

2011　　　　　Ａ
　　　　　　　Ｂ

2012　Ｃ　　　Ｄ
　　　Ｅ

このように変換する良い方法はありませんでしょうか？
基本的なことで恐縮ですが、ご教示いただきたいです。
よろしくお願いします。

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

 おはようございます　＾＾
いろいろ、方法は有ると思いますが。。。
ＶＢＡでしたら
１．作業シートへコピー後、年度で昇順並び替え（並んでたら良いのですが念のため）
２．上から順にポジション別の配列に各ポジションに該当すればお名前を格納していく
３．年度が変わるタイミングで、連想配列等にでも年度と配列を格納、使用配列の初期化
　　上記を最後まで繰り返す。
４．作った連想配列から年度、各ポジションの配列を取り出し、所定のセルに書き出す
とかでも出来なくはないかと。wややこしそぉ。。←　多分。。。自信ありません。。。＾＾；
でわ。。。m(_ _)m
（隠居じーさん） 2020/05/15(金) 09:09

＞数字の集計の場合はピボットテーブルを使えばいろいろできると思いますが、
＞文字列をそのまま表に残したい場合どうすればいいのか、

手作業だと、こんな感じでできそうです。

１）ピボットで個数をカウント
２）ピボットを値に変換
３）個数を数式で氏名に置換
４）年毎に、氏名を上に詰める
５）不要行、列を削除

それをマクロにすると

 Option Explicit

 Sub test()
    Dim ws As Worksheet
    Dim tbl As Range
    Dim pvt As PivotTable
    Dim pvf As PivotField
    Dim a As Range
    Dim r As Range
    Dim k As Long
    Dim v

    Set ws = ActiveSheet
    Set tbl = ws.Cells(1).CurrentRegion

    With ws.Parent.PivotCaches.Create(xlDatabase, tbl).CreatePivotTable("")
         .RowAxisLayout xlTabularRow
        .ColumnGrand = False
        .RowGrand = False
        For Each pvf In .PivotFields
            pvf.Subtotals(1) = False
        Next
        .AddDataField .PivotFields("氏名"), , xlCount
        .AddFields Array("入社", "氏名"), "ポジション"

        .TableRange1.Copy
        .TableRange1.PasteSpecial xlPasteValues
    End With

    Set tbl = Cells(1).Cells(1).CurrentRegion
    With Intersect(tbl, tbl.Offset(2, 2))
        .SpecialCells(xlCellTypeConstants).FormulaR1C1 = "=rc2"
        .Value = .Value
    End With

    For Each a In Cells(1).CurrentRegion.Columns(1).SpecialCells(xlCellTypeBlanks).Areas
        For k = 3 To tbl.Columns.Count
            With a.Resize(a.Count + 1).Offset(-1, k - 1)
                If WorksheetFunction.CountA(.Cells) > 0 Then
                    v = WorksheetFunction.Transpose(.Value)
                    v = Split(WorksheetFunction.Trim(Join(v)))
                    .ClearContents
                    .Resize(UBound(v) + 1).Value = WorksheetFunction.Transpose(v)
                End If
            End With
        Next

        For Each r In Intersect(tbl, a.EntireRow).Rows
            If WorksheetFunction.CountIf(r, "<>") < 2 Then
                r.Delete xlShiftUp
            End If
        Next
    Next

    Rows(1).Delete
    Columns(2).Delete

 End Sub

（マナ） 2020/05/15(金) 12:37

 おはようございます　＾＾
既に、ご案内のようですが。。。作ってみましたので。。。
汗顔の至りですが。。。m(_ _)m
Option Explicit
Sub OneInstanceM1()
    Const zProgramID As String = "zBase09.xlsm"
    Dim zTb           As Workbook
    Dim i             As Long
    Dim j             As Long
    Dim k             As Long
    Dim n             As Long
    Dim zKcnt()       As Long
    Dim zBase()       As Variant
    Dim 課長()        As Variant
    Dim 係長()        As Variant
    Dim zD            As Object
    Dim zVar          As Variant
    Set zD = CreateObject("Scripting.Dictionary")
    Set zTb = Workbooks(zProgramID)
    zTb.Worksheets("Sheet1").Copy zTb.Worksheets(1)
    With zTb.ActiveSheet
        .Cells(1).CurrentRegion.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
        zBase = .Cells(1).CurrentRegion.Offset(1).Value
    End With
    Application.DisplayAlerts = False
    zTb.ActiveSheet.Delete
    Application.DisplayAlerts = True
    ReDim 課長(0), 係長(0)
    For i = 1 To UBound(zBase, 1) - 1
        If zBase(i, 2) = "課長" Then
            ReDim Preserve 課長(j)
            課長(j) = zBase(i, 3)
            j = j + 1
        End If
        If zBase(i, 2) = "係長" Then
            ReDim Preserve 係長(k)
            係長(k) = zBase(i, 3)
            k = k + 1
        End If
        If zBase(i, 1) <> zBase(i + 1, 1) Then
        zD(n) = Array(zBase(i, 1), 課長, 係長)
        n = n + 1
        ReDim 課長(0), 係長(0)
        j = 0
        k = 0
        End If
    Next
    With zTb.Worksheets("Sheet2")
        .UsedRange.Clear
        i = 2: k = 1: n = 0
        .Cells(1).Resize(, 3) = Array("年度", "課長", "係長")
        For Each zVar In zD
            For j = 0 To 2
                If j > 0 Then
                    ReDim Preserve zKcnt(n)
                    zKcnt(n) = UBound(zD(zVar)(j))
                    n = n + 1
                    .Cells(i, k + j).Resize(UBound(zD(zVar)(j)) + 1, 1) = Application.Transpose(zD(zVar)(j))
                    If j = 2 Then
                        i = i + WorksheetFunction.Max(zKcnt) + 1
                        Erase zKcnt
                        n = 0
                    End If
                Else
                    .Cells(i, 1) = zD(zVar)(j)
                End If
            Next
        Next
        .UsedRange.Columns.AutoFit
        .Activate
    End With
    Erase zBase, 課長, 係長, zKcnt
    Set zD = Nothing
    Set zTb = Nothing
End Sub
（隠居じーさん） 2020/05/16(土) 09:32

 おはようございます。
ちょっと書いてみました。。
一応、、部長さんもいらっしゃるかなと思って↓みたいなデータがあったとしたら

 入社	ポジション	氏名
2011	係長	　　　　Ａ
2011	係長	　　　　Ｂ
2012	課長	　　　　Ｃ
2012	係長	　　　　Ｄ
2012	課長	　　　　Ｅ
2013	部長	　　　　ｑ

 こんな感じになりました。。ちょっと順番が逆ですけど。。出現順ですね(^^;

 	係長	課長	部長
2011	Ａ		
	Ｂ		
2012	Ｄ	Ｃ	
		Ｅ	
2013			ｑ

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim v As Variant
Dim x As Variant
Dim MyP() As Variant
Dim i As Long
Dim n As Long
Dim k As Long
MyA = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
ReDim MyP(0)
For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
    x = Application.Match(MyA(i, 2), MyP, 0)
    If IsError(x) Then
        ReDim Preserve MyP(n)
        MyP(n) = MyA(i, 2)
        n = n + 1
    End If
Next
ReDim v(1 To UBound(MyA, 1), 1 To UBound(MyP) + 2)
k = 1
For i = LBound(MyP) To UBound(MyP)
    v(k, i + 2) = MyP(i)
Next
For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
    If UBound(Filter(Application.Transpose(Application.Index(v, 0, 1)), MyA(i, 1), True)) Then
        k = k + 1
        v(k, 1) = MyA(i, 1)
        x = Application.Match(MyA(i, 2), MyP, 0)
        If Not IsError(x) Then
            v(k, x + 1) = MyA(i, 3)
        End If
    Else
        x = Application.Match(MyA(i, 2), MyP, 0)
        If Not IsError(x) Then
            If Not IsEmpty(v(k, x + 1)) Then k = k + 1
            v(k, x + 1) = MyA(i, 3)
        End If
    End If
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(k, UBound(v, 2)).Value = v
End With
Erase MyA, v, MyP
End Sub
MyYは使ってませんでした。。。m(__)m
（SoulMan） 2020/05/16(土) 10:56

コメント返信：

[ 一覧(最新更新順) ]

[[20200514161450]] 『クロス集計の逆の表を作る方法』（Ｙ） ページの最後に飛ぶ

[[20200514161450]]　『クロス集計の逆の表を作る方法』（Ｙ）　ページの最後に飛ぶ