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            


        

Answer 1

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