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

Answer 2

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