Excel VBA - Loop Transpose

Question

I have a certain range of data. Below are the example data:

PAT   PID 0     Min     3001
PAT   PID 0     Mean    3754
PAT   PID 0     Max     4542
CAT   PID 1     Min     15004
CAT   PID 1     Mean    15040
CAT   PID 1     Max     15141
EMM   PID 201   Min     32105
EMM   PID 201   Mean    584120
EMM   PID 201   Max     1339633

And I would like to transpose the data as follow:

PAT   PID 0     3001  3754   4542
CAT   PID 1     15004 15040  15141
EMM   PID 201   32105 584120 1339633

I found a similar situation posted in the forum previously(as below)

VBA Code - Copy and Transpose paste with specific conditions

Unfortunately i get this error "error 9: Subscript out of range.". I have checked the sheet name and debugged everything but no luck.

Edited

As requested below are the code i tried to used:

Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key

x = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
For Each CLa In Sheets("Sheet3").Range("A1:A" & x)
If Not Dic.exists(CStr(CLa.Value)) Then
    ID = CLa.Value

    For Each CLb In Sheets("Sheet3").Range("A1:A" & x)
        If CLb.Value = ID Then

            If Names = "" Then
                Names = CLb.Offset(, 1).Value
            Else
                Names = Names & "," & CLb.Offset(, 1).Value
            End If

        End If
    Next CLb

Dic.Add ID, Names
End If
ID = Empty: Names = Empty
Next CLa

x = 1
For Each Key In Dic
Sheets("Sheet2").Cells(x, 1).Value = Key
Sheets("Sheet2").Range(Cells(x, 2), Cells(x, 4)) = Split(Dic(Key), ",")
x = x + 1
Next Key

Sheets("Sheet2").Cells.Replace "#N/A", Replacement:=""

End Sub

Answer 1

Try this:

Sub test()
      Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
      Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key
      Dim n As Integer
      Dim trValue() As String


      x = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
      For Each CLa In Sheets("Sheet3").Range("A1:A" & x)
          If Not Dic.exists(CStr(CLa.Value)) Then
              ID = CLa.Value

              For Each CLb In Sheets("Sheet3").Range("A1:A" & x)
                  If CLb.Value = ID Then

                      If Names = "" Then
                          Names = CLb.Offset(, 3).Value
                      Else
                          Names = Names & "," & CLb.Offset(, 3).Value
                      End If

                  End If

              Next CLb

              Dic.Add ID, Names
          End If
      ID = Empty: Names = Empty
      Next CLa

      x = 1
      n = 0
      For Each Key In Dic
          Sheets("Sheet2").Cells(x, 1).Value = Key

          trValue = Split(Dic(Key), ",")
          For n = 0 To UBound(trValue)
              Sheets("Sheet2").Cells(x, n + 2).Value = Trim(trValue(n))
          Next n



          x = x + 1
      Next Key

    Sheets("Sheet2").Cells.Replace "#N/A", Replacement:=""

End Sub

Answer 2

Since you want to keep the values of columns A:C as a unique ID, there is a need to "Merge" them together as a String when saving them inside the Dictionary as Keys (adding a , in between them). Later, when extracting the information to "Sheet2", we can use the Split funtion to extract the string to 3 elements in IDVal array.

Option Explicit

Sub TestDict()

Dim Dic As Object
Dim CLa As Range, CLb As Range, lRow As Long
Dim Names As String, ID$, Key As Variant, KeyVal As Variant, IDVal As Variant

Set Dic = CreateObject("Scripting.Dictionary")

With Sheets("Sheet3")
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    For Each CLa In .Range("A1:A" & lRow).Cells
        If Not Dic.exists(CStr(CLa.Value & "," & CLa.Offset(0, 1).Value & "," & CLa.Offset(0, 2).Value)) Then  ' If Not Dic.exists(CStr(CLa.Value)) Then
            ID = CLa.Value

            For Each CLb In .Range("A1:A" & lRow).Cells

                If CLb.Value = ID Then
                    If Names = "" Then
                        Names = CLb.Offset(, 4).Value
                    Else
                        Names = Names & "," & CLb.Offset(, 4).Value
                    End If
                End If
            Next CLb

            ' "Fix"ing the key to include values from columns A:C >> will split them later
            ID = CLa.Value & "," & CLa.Offset(0, 1).Value & "," & CLa.Offset(0, 2).Value

            Dic.Add ID, Names
        End If

        ID = Empty: Names = Empty
    Next CLa
End With

lRow = 1
With Sheets("Sheet2")
    For Each Key In Dic.Keys
        ' splitting values from "Merged" string Key to array
        IDVal = Split(Key, ",")
        .Range("A" & lRow).Resize(1, UBound(IDVal) + 1).Value = IDVal

        KeyVal = Split(Dic(Key), ",")
        .Range("D" & lRow).Resize(1, UBound(KeyVal) + 1).Value = KeyVal
        lRow = lRow + 1
    Next Key

End With

End Sub