エクセルVBAで表の転地について

エクセルVBAで縦持ちのデータを横持ちの状態に変えたいのですが、処理が思いつきません。
ご教示いただけますと幸いです。

下記のデータを

aaa	bbb	ccc
1	a	X
1	a	Y
1	a	Z
2	b	AA
2	b	BB
2	b	ZZ
3	c	XX
3	c	YY

下記の様に変えたいと思っております。

aaa	bbb	ccc
1	a	X,Y,Z
2	b	AA,BB,ZZ
3	c	XX,YY

エクセルのバージョンは2016、OSはwindows10 home 64bitとなります。
恐れ入りますが、ご教示お願い申し上げます。

mattuwan

2020/05/21 04:04

キーとなる列はaaaだけでいいか、aaaとbbbと2種類になるか、サンプルデータでは判別できません。どちらでしょうか？

FredericChopin

2020/05/21 04:11

aaaとbbbの2種類となります。

行動規範の内容に同意します

回答2件

ExcelVBA
1Sub test()
2    Dim a As Range
3    
4    Application.ScreenUpdating = False
5    
6    ActiveSheet.Range("A1").CurrentRegion.Subtotal 1, xlCount, 3
7    ActiveSheet.Range("A1").CurrentRegion.Subtotal 2, xlCount, 3
8    With ActiveSheet.Range("A1").CurrentRegion
9        For Each a In .Offset(1).Columns(3).SpecialCells(xlCellTypeConstants).Areas
10            On Error GoTo ErrLabel
11            a.Cells(1, 2).Value = Join(WorksheetFunction.Transpose(a), ",")
12            On Error GoTo 0
13        Next
14        .RemoveSubtotal
15    End With
16    ActiveSheet.Range("A1").CurrentRegion.RemoveDuplicates Array(1, 2), xlYes
17    ActiveSheet.Range("A1").CurrentRegion.Offset(1).Columns(3).Delete xlShiftToLeft
18    
19    Exit Sub
20    
21ErrLabel:
22   a.Cells(1, 2).Value = a.Value
23   Resume Next
24End Sub

こんな感じですかね。
参考になれば。

投稿2020/05/21 09:51

mattuwan

総合スコア2163

ベストアンサー

下記VBAプログラムをそのまま対象シートへ貼り付けて実行して見て下さい。

Option Explicit
'-------------------------------------------------
'(運用条件)
'読込み範囲:A1～A100/1行目タイトル/空白行出現で終了
'書込み範囲:E1より書込み
'-------------------------------------------------
Sub Test_Sample_Miniature()
    
    '定義Work
    Dim MySeaArea As Range
    Dim MyRange As Range
    
    Dim blnInitFlag As Boolean
    Dim blnWriteFlag As Boolean
    Dim lRow As Long
    
    '定義ブレーク
    Dim strBreakKey As String
    Dim strBreakA As String
    Dim strBreakB As String
    Dim strWorkKey As String
    
    '定義書込み位置
    Dim MyWrtA As Range
    Dim MyWrtB As Range
    Dim MyWrtC As Range
    
    '定義-<値の設定>検索範囲セル&書込みセル
    Set MySeaArea = Range("A2:A100")
    Set MyWrtA = Range("E1")
    Set MyWrtB = Range("F1")
    Set MyWrtC = Range("G1")
    
    '初期値設定
    blnInitFlag = True
    strBreakKey = ""
    
    '開始
    lRow = MyWrtA.Row
    For Each MyRange In MySeaArea
        '
        '終了処理
        If Trim(MyRange) = "" Then Exit For
        '
        '初期処理
        blnWriteFlag = True
        If blnInitFlag = True Then
            '1行目タイトル
            Cells(lRow, MyWrtA.Column) = Cells(MyRange.Row - 1, MyRange.Column + 0)
            Cells(lRow, MyWrtB.Column) = Cells(MyRange.Row - 1, MyRange.Column + 1)
            Cells(lRow, MyWrtC.Column) = Cells(MyRange.Row - 1, MyRange.Column + 2)
            '2行目初期
            lRow = lRow + 1
            Cells(lRow, MyWrtA.Column) = Cells(MyRange.Row, MyRange.Column + 0)
            Cells(lRow, MyWrtB.Column) = Cells(MyRange.Row, MyRange.Column + 1)
            Cells(lRow, MyWrtC.Column) = Cells(MyRange.Row, MyRange.Column + 2)
            strBreakA = Cells(MyRange.Row, MyRange.Column + 0)
            strBreakB = Cells(MyRange.Row, MyRange.Column + 1)
            strBreakKey = strBreakA & strBreakB
            '初期処理完了
            blnInitFlag = False
            blnWriteFlag = False
        End If
        '
        'ブレーク処理
        If blnWriteFlag = True Then
            strWorkKey = Cells(MyRange.Row, MyRange.Column + 0) & _
                         Cells(MyRange.Row, MyRange.Column + 1)
            If strBreakKey <> strWorkKey Then
                lRow = lRow + 1
                Cells(lRow, MyWrtA.Column) = Cells(MyRange.Row, MyRange.Column + 0)
                Cells(lRow, MyWrtB.Column) = Cells(MyRange.Row, MyRange.Column + 1)
                Cells(lRow, MyWrtC.Column) = Cells(MyRange.Row, MyRange.Column + 2)
                strBreakA = Cells(MyRange.Row, MyRange.Column + 0)
                strBreakB = Cells(MyRange.Row, MyRange.Column + 1)
                strBreakKey = strBreakA & strBreakB
                blnWriteFlag = False
            End If
        End If
        '
        '計算・書込み処理
        If blnWriteFlag = True Then
            Cells(lRow, MyWrtC.Column) = Cells(lRow, MyWrtC.Column) & _
                                    "," & _
                                    Cells(MyRange.Row, MyRange.Column + 2)
        End If
        '
    Next

    '最終レコード処理(今回は処理なし)
    If strBreakKey <> "" Then
    End If

    'オブジェクト開放
    Set MySeaArea = Nothing
    Set MyRange = Nothing
    Set MyWrtA = Nothing
    Set MyWrtB = Nothing
    Set MyWrtC = Nothing

End Sub

投稿2020/05/21 07:04

編集2020/06/01 05:30