VBAでテーブル形式のリストからクロス形式のリストを作成したい（その際、特定の文字を含まない場合、次列のセルに移動する指示を出したい）

Question

お世話になります。
VBA及びマクロ初心者ですが、皆様のお力を貸していただきたく思います。

現在、Excelで以下のようなテーブル形式の表から別シートへクロス形式の一覧表を作成する為のマクロに取り組んでおります。

＜リスト1のシート＞

番号	属性
1000	A
1000	B
1000	C
1001	A
1001	B
1001	C
1002	E
1000	D
1000	E

------以下略------

＜リスト2のシート＞

番号	属性1	属性2	属性3	属性4	属性5
1000	A	B	C	D	E
1001	A	B	C
1002					E

------以下略------

リスト2のシートへの転記のコードが以下となります。
（ネット上に挙げられていたものを引用・編集させていただきました。）

Private Sub CommandButton1_Click()

 Call A
 Call B
 Call C
 Call D
 Call E

End Sub
---------------------------------------------------------------------------------
Sub A()

Dim i As Long
Dim a() As Variant
Dim j As Long

j = 1
For i = 1 To Sheets("リスト1").Range("B" & Rows.Count).End(xlUp).Row
'セルにAがあるか
If Sheets("リスト1").Cells(i, 2).Value Like "*A*" Then
ReDim Preserve a(j)
a(j) = Sheets("リスト1").Cells(i, 2).Value
j = j + 1
End If
Next

For j = LBound(a) To UBound(a)
Sheets("リスト2").Cells(j + 2, 2).Value = a(j)
Next

End Sub
---------------------------------------------------------------------------------
Sub B()

Dim i As Long
Dim a() As Variant
Dim j As Long

j = 1
For i = 1 To Sheets("リスト1").Range("B" & Rows.Count).End(xlUp).Row
'セルにBがあるか
If Sheets("リスト1").Cells(i, 2).Value Like "*B*" Then
ReDim Preserve a(j)
a(j) = Sheets("リスト1").Cells(i, 2).Value
j = j + 1
End If
Next

For j = LBound(a) To UBound(a)
Sheets("リスト2").Cells(j + 2, 3).Value = a(j)
Next

End Sub
---------------------------------------------------------------------------------
Sub C()

Dim i As Long
Dim a() As Variant
Dim j As Long

j = 1
For i = 1 To Sheets("リスト1").Range("B" & Rows.Count).End(xlUp).Row
'セルにCがあるか
If Sheets("リスト1").Cells(i, 2).Value Like "*C*" Then
ReDim Preserve a(j)
a(j) = Sheets("リスト1").Cells(i, 2).Value
j = j + 1
End If
Next

For j = LBound(a) To UBound(a)
Sheets("リスト2").Cells(j + 2, 4).Value = a(j)
Next

End Sub
---------------------------------------------------------------------------------
Sub D()

Dim i As Long
Dim a() As Variant
Dim j As Long

j = 1
For i = 1 To Sheets("リスト1").Range("B" & Rows.Count).End(xlUp).Row
'セルにDがあるか
If Sheets("リスト1").Cells(i, 2).Value Like "*D*" Then
ReDim Preserve a(j)
a(j) = Sheets("リスト1").Cells(i, 2).Value
j = j + 1
End If
Next

For j = LBound(a) To UBound(a)
Sheets("リスト2").Cells(j + 2, 5).Value = a(j)
Next

End Sub
---------------------------------------------------------------------------------
Sub E()

Dim i As Long
Dim a() As Variant
Dim j As Long

j = 1
For i = 1 To Sheets("リスト1").Range("B" & Rows.Count).End(xlUp).Row
'セルにEがあるか
If Sheets("リスト1").Cells(i, 2).Value Like "*E*" Then
ReDim Preserve a(j)
a(j) = Sheets("リスト1").Cells(i, 2).Value
j = j + 1
End If
Next

For j = LBound(a) To UBound(a)
Sheets("リスト2").Cells(j + 2, 6).Value = a(j)
Next

End Sub
---------------------------------------------------------------------------------

このコードに加えて、「リスト1の番号とリスト2の番号が一致する場合」という条件式と、「リスト1の属性に該当の属性が入力されていない場合、空白処理をする」という指示をしたいのです。

リスト1作成時の条件・注意点として
・番号は4桁で基本的には連番となるが、若い番号が行の最後に入る可能性がある
・属性列はA～Dまで必ずしもすべてが順番通りに入るとは限らない
・リスト1には連続で入力されるため空白セルは存在しない
以上のことが挙げられます。
最終的なリスト2の形といたしまして「リスト1の番号とリスト2の番号が一致したとき」、その番号に対して1行の表を作成したく、「該当の属性が存在しない場合」は空白処理をして、次の番号に対する表を作成する指示を出したいのです。
また、後から若い番号の属性データが入力されていた場合、若い番号の行に戻って該当する属性列に入力されるようにしたいのですが、いくら調べても対応できるコード見つけることができませんでした。

作成したい表は明確なのですが、うまく文章にすることができず、伝わりにくい箇所も多々あると思いますが、検索の仕方や利用できそうなコードがありましたらご教示いただけますと幸いです。

加えて上記の各コードの

For j = LBound(a) To UBound(a)
Sheets("リスト2").Cells(j + 2, ○).Value = a(j)
Next

この部分で必ずデバックが上がってしまうのですが、それについての対策や考えられるエラーの理由等もご教示いただけますと嬉しく思います。

私自身の力・経験・知識不足で長々と書き連ねてしまい、大変申し訳ございませんが、皆様のお力をお貸しいただけますと幸いです。
何卒、宜しくお願い申し上げます。

※追記1※
コードの使用につきまして、こちらにも記述させていただきます。
目的といたしましてはリスト2の作成ですので、上記のコードを使用せず作業することもできるかと思います。
ただ、誰が作業してもシンプルでわかりやすくしたかったため、ボタンを用いる方が直感的でわかりやすいのではないかと思いこの方法を取らせていただいております。
（最終的にリスト2のデータを使用する為、数式等は入らず文字列として転記する必要があったことから等号で反映させることもしたくなかったのです。）

また、属性につきましては文言は伏せさせていただいておりますが、A～Dは固定となっております。リスト2の番号は入力済みであることを前提に作業を進める予定です。

さらにAccessを使用したほうがわかりやすいのだとは思うのですが、作業環境にAccessがないため候補から除外させていただいております。

改めて、宜しくお願い致します。

※追記2※
ご回答いただき誠にありがとうございます。
コメント欄で追加で質問させていただいておりましたが、失礼だったと思います。
大変申し訳ございません。
改めて、こちらに記載させていただきます。

現在、h-okhs様、hatena19様お二人の方法を試させていただき、どちらもしっかり表を作成することに成功いたしました。
本当にありがとうございました。
以下、追加での質問となります。
属性が「1_A_○」や「2_B_○」といった文字列になっている際、「A」や「B」をキー項目として、そのセル丸ごとを転記する際は、質問にも載せさせていただいているIFから始まるコードを使用しても問題ないでしょうか？

申し訳ございませんが、この点につきましてもご教授いただけますと幸いです。
よろしくお願いいたします。

※追記3※
ご回答いただいた皆様、誠にありがとうございました。
拙い文章から私の目的をご理解いただき、なんとお礼を申し上げたらよいか…。
どの回答をBAにするかすごく迷いましたが、シンプルで分かりやすかったこと、丁寧に導いてくださったhatena19様とさせていただきました。
改めて、皆様お世話になりました。

Comments

[h-okhs]

このネットで拾ってきたとおっしゃっているイケてないコードを修正して完成させる必要があるのか、それとも目的はリスト2の表を作ることで、このコードは使わなくてもいいのか、どちらでしょうか？

[shibakoppe]

正直に申し上げれば使う必要性はないと感じております。
リスト1の形からリスト2の形へ変更というか転記をしたいというのが目的なので、本末転倒になってしまいますがVBAでなくても可能な作業だとは思っています。
ボタン一つで自動化するという行為が使用者問わずわかりやすいと感じたため、VBAで作業できたら…という思いで、このコードを使用してみました。

[hatena19]

属性1はA、属性2はB・・ という対応は固定でいいのですか。
シート2の番号は入力済みですか。

[shibakoppe]

>>hatena19様
属性につきましては固定で問題ありません。
また、シート2の番号も入力済みという前提で進めようと思っております。
シート1のリストを蓄積していき、作業が全て完了した後にシート2のリストへの転記をする予定です。

Answer 1

「属性が「1_A_○」や「2_B_○」といった文字列になっている際、「A」や「B」をキー項目として、そのセル丸ごとを転記する」ようにしました。

Option Explicit
'クロス表作成
Public Sub CommandButton1_Click()
    Dim dicT As Object
    Dim keywd As Variant
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow1 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim key As Variant
    Dim arr As Object
    Dim i As Long
    Set dicT = CreateObject("Scripting.Dictionary")
    Set sh1 = Worksheets("リスト1")
    Set sh2 = Worksheets("リスト2")
    keywd = Array("*A*", "*B*", "*C*", "*D*", "*E*")
    'リスト2クリア
    sh2.Rows("2:" & Rows.count).ClearContents
    maxrow1 = sh1.Cells(Rows.count, "A").End(xlUp).Row    'A列の最大行取得
    For row1 = 2 To maxrow1
        key = sh1.Cells(row1, "A").Value
        If dicT.exists(key) = False Then
            Set arr = CreateObject("System.Collections.ArrayList")
            dicT.Add key, arr
            For i = 0 To UBound(keywd)
                dicT(key).Add ""
            Next
        End If
        For i = 0 To UBound(keywd)
            If sh1.Cells(row1, "B").Value Like keywd(i) Then
                dicT(key)(i) = sh1.Cells(row1, "B").Value
                Exit For
            End If
        Next
    Next
    row2 = 2
    For Each key In dicT.keys
        sh2.Cells(row2, "A").Value = key
        For i = 0 To UBound(keywd)
            sh2.Cells(row2, 2 + i).Value = dicT(key)(i)
        Next
        row2 = row2 + 1
    Next
    sh2.Range(sh2.Cells(1, 1), sh2.Cells(row2 - 1, UBound(keywd) + 2)).Sort key1:=Range("A1"), Header:=xlYes
    MsgBox ("完了")
End Sub

別解
System.Collections.ArrayListを使用しない方法です。

Option Explicit
'クロス表作成
Public Sub CommandButton1_Click()
    Dim dicT As Object
    Dim keywd As Variant
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow1 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim key As Variant
    Dim arr As Variant
    Dim i As Long
    Set dicT = CreateObject("Scripting.Dictionary")
    Set sh1 = Worksheets("リスト1")
    Set sh2 = Worksheets("リスト2")
    keywd = Array("*A*", "*B*", "*C*", "*D*", "*E*")
    'リスト2クリア
    sh2.Rows("2:" & Rows.count).ClearContents
    maxrow1 = sh1.Cells(Rows.count, "A").End(xlUp).Row    'A列の最大行取得
    For row1 = 2 To maxrow1
        key = sh1.Cells(row1, "A").Value
        If dicT.exists(key) = False Then
            arr = Array("", "", "", "", "", "")
            dicT.Add key, arr
        End If
        arr = dicT(key)
        For i = 0 To UBound(keywd)
            If sh1.Cells(row1, "B").Value Like keywd(i) Then
                arr(i) = sh1.Cells(row1, "B").Value
                Exit For
            End If
        Next
        dicT(key) = arr
    Next
    row2 = 2
    For Each key In dicT.keys
        sh2.Cells(row2, "A").Value = key
        For i = 0 To UBound(keywd)
            sh2.Cells(row2, 2 + i).Value = dicT(key)(i)
        Next
        row2 = row2 + 1
    Next
    sh2.Range("A1:F" & row2 - 1).Sort key1:=Range("A1"), Header:=xlYes
    MsgBox ("完了")
End Sub

Comments

[shibakoppe]

ご回答いただき誠にありがとうございます。
追加の質問にもご対応いただき感謝申し上げます。
実際に記述してみたところ、エラーが起き「Set arr = CreateObject("System.Collections.ArrayList")」この構文の部分で引っかかってしまっているようなのです…。（ポップアップにはオートメーションエラーとありました。）
特に他のアプリを立ち上げているわけでもなく、メモリ的にも問題ないと思うのですが、このような場合の対処法をご教示いただいてもよろしいでしょうか…？

[tatsu99]

すみません。
こちらを参考にして、「Windows機能の有効化または無効化」で
「.NET Framework 3.5」を有効にしてください。
https://y-moride.com/vba/arraylist-how-to-use.html

[shibakoppe]

ご丁寧にありがとうございます！
試してみます！
別解も載せていただき誠にありがとうございます◎

Answer 2

属性につきましては固定で問題ありません。
また、シート2の番号も入力済みという前提で進めようと思っております。

上記の仕様なら、下記のコードでいけます。

Private Sub CommandButton1_Click()
    Dim ws1 As Worksheet
    Set ws1 = Sheets("リスト1")
    Dim ws2 As Worksheet
    Set ws2 = Sheets("リスト2")
    
    Dim i As Long, r As Long, c As Long
    With ws1
        For i = 2 To .Range("B" & Rows.Count).End(xlUp).Row
            r = WorksheetFunction.Match(.Cells(i, 1), ws2.Range("A:A"), 0)
            c = WorksheetFunction.Match(.Cells(i, 2), Array("A", "B", "C", "D", "E"), 0) + 1
            ws2.Cells(r, c).Value = .Cells(i, 2)
        Next
    End With
End Sub

存在しない番号や属性値があった場合はエラーになりますので、必要に応じてエラー処理を追加する必要があります。
その場合は下記のコードで。

Private Sub CommandButton1_Click()
    Dim ws1 As Worksheet
    Set ws1 = Sheets("リスト1")
    Dim ws2 As Worksheet
    Set ws2 = Sheets("リスト2")
    
    Dim i As Long, r As Long, c As Long
    With ws1
        On Error Resume Next
        For i = 2 To .Range("B" & Rows.Count).End(xlUp).Row
            r = WorksheetFunction.Match(.Cells(i, 1), ws2.Range("A:A"), 0)
            If Err.Number = 0 Then
                c = WorksheetFunction.Match(.Cells(i, 2), Array("A", "B", "C", "D", "E"), 0) + 1
                If Err.Number = 0 Then ws2.Cells(r, c).Value = .Cells(i, 2)
            End If
        Next
        On Error GoTo 0
    End With
End Sub

追記

コメントにあった属性値を部分一致で検索する場合のコード例です。
WorksheetFunction.Matchを部分一致で検索するユーザー定義関数に置き換えました。

Private Sub CommandButton1_Click()
    Dim ws1 As Worksheet
    Set ws1 = Sheets("リスト1")
    Dim ws2 As Worksheet
    Set ws2 = Sheets("リスト2")
    
    Dim i As Long, r As Long, c As Long
    With ws1
        On Error Resume Next
        For i = 2 To .Range("B" & Rows.Count).End(xlUp).Row
            r = WorksheetFunction.Match(.Cells(i, 1), ws2.Range("A:A"), 0)
            If Err.Number = 0 Then
                c = MyMatch(.Cells(i, 2), Array("A", "B", "C", "D", "E"))
                If c > 0 Then ws2.Cells(r, c + 1).Value = .Cells(i, 2)
            End If
        Next
        On Error GoTo 0
    End With
End Sub


Public Function MyMatch(v As String, ary) As Long
    Dim i As Long
    For i = 0 To UBound(ary)
        If v Like "*" & ary(i) & "*" Then
            MyMatch = i + 1
            Exit For
        End If
    Next
End Function

Comments

[shibakoppe]

ご回答いただきまして誠にありがとうございます。
エラー対応時の構文まで載せていただき、とても勉強になりました。
また、こちらで質問させていただくのは失礼かと思ったのですが、以下を併せてお教えいただきたく存じます。
h-okhs様にも同じご質問させていただいたのですが、属性が「1_A_○」や「2_B_○」といった文字列になっている際、「A」や「B」をキー項目として、そのセル丸ごとを転記する際は、質問にも載せさせていただいているIFから始まるコードを使用しても問題ないでしょうか？

[shibakoppe]

追加の質問にもご対応いただきまして誠にありがとうございます。
部分一致のコードでも無事に表を作成することができました。

Answer 3

まずDictionaryというデータを入れるオブジェクトにリスト1のデータを詰め込んで、その後、それをリスト2にマッピングする形にしました。

Sub クロス表()

    Dim dic As Object
    Set dic = Dictionary生成()
    Dim lines As Integer
    lines = リスト2生成(dic)
    Call ソート(lines)
    
End Sub


Function Dictionary生成() As Object

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    For i = 2 To Sheets("リスト1").Range("B" & Rows.Count).End(xlUp).row
    
        Dim 番号 As Integer
        番号 = Sheets("リスト1").Cells(i, 1).Value
        Dim 属性 As String
        属性 = Sheets("リスト1").Cells(i, 2).Value
        If Not dic.Exists(番号) Then
            Dim a(5) As Variant
            dic.Add 番号, a
        End If
        Dim 属性リスト As Variant
        属性リスト = dic.Item(番号)
        属性リスト(Asc(属性) - Asc("A") + 1) = 属性
        dic.Item(番号) = 属性リスト
    Next
    
    Set Dictionary生成 = dic

End Function

Function リスト2生成(ByRef dic As Object)

    Dim currentRow As Integer
    currentRow = 2
    For Each 番号 In dic
        Sheets("リスト2").Cells(currentRow, 1).Value = 番号
        For i = 1 To 5
            Sheets("リスト2").Cells(currentRow, i + 1).Value = dic.Item(番号)(i)
        Next
        currentRow = currentRow + 1
    Next
    
    リスト2生成 = currentRow - 1

End Function

Sub ソート(ByVal lines As Integer)
    
    Range("A2:F" & lines).Select
    Sheets("リスト2").Sort.SortFields.Clear
    Sheets("リスト2").Sort.SortFields.Add2 Key:=Range("A2:A" & lines), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("リスト2").Sort
        .SetRange Range("A2:F" & lines)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub

Comments

[h-okhs]

前提は属性値はA~E固定、シート2は空っぽ(番号未入力)でよい

[shibakoppe]

ご回答いただきまして誠にありがとうございます。
とても助かりました。
こちらで質問させていただくのは失礼かと思ったのですが、以下を併せてお教えいただきたく存じます。
属性が「1_A_○」や「2_B_○」といった文字列になっている際、「A」や「B」をキー項目として、そのセル丸ごとを転記する際は、質問にも載せさせていただいているIFから始まるコードを使用しても問題ないでしょうか？

Answer 4

Sub Macro1()
    Dim rngOld As Range: Set rngOld = Worksheets("Sheet1").Range("A1").CurrentRegion
    Dim rngNew As Range: Set rngNew = Worksheets("Sheet2").Range("A1")
    
    Dim pvtCache As PivotCache
    Dim pvtTable As PivotTable
    Set pvtCache = ThisWorkbook.PivotCaches.Create(xlDatabase, rngOld)
    Set pvtTable = pvtCache.CreatePivotTable(rngNew)
    
    With pvtTable
        .PivotFields(rngOld(1).Value).Orientation = xlRowField
        .PivotFields(rngOld(2).Value).Orientation = xlColumnField
        .PivotFields(rngOld(2).Value).Orientation = xlDataField
        .ColumnGrand = False
    End With
End Sub

こんな感じで。。。。あとは好きなように編集したらよいかと。

Comments

[shibakoppe]

ご回答いただきありがとうございます。