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

What code are you using? Can you post it please? Also, let us know what line throws the error. — BruceWayne, Dec 14 '16 at 08:11
Haven't seen your code yet. But here is a solution to a very similar problem. Also look at other answers in the same post. http://stackoverflow.com/a/41031394/1651993 — nightcrawler23, Dec 14 '16 at 08:38
step into your code with F8 and let us know which line the error is on — Preston, Dec 14 '16 at 08:55
When i press F8, the first line highlighted. Btw, i now im getting "Run-time error 1004: Application-defined or object-defined error" — MG78, Dec 14 '16 at 09:00
@tompreston did you notice he his using **Late Binding** for the `Dictionary`, right ? — Shai Rado, Dec 14 '16 at 09:54
First, can you remove the suffixes in the variable names? Second, you don't often see something set to empty (I don't know if this is considered good practice?), Third, you're dimensioning Key as variant, is this what you want? Finally, this doesn't compile for me unless i use worksheets in the place of sheets — Preston, Dec 14 '16 at 10:06
@Jeeva read my answer below, and try the code to see if it works as you intended — Shai Rado, Dec 14 '16 at 14:21
@Jeeva have you tried the code in my answer below ? any feedback ? — Shai Rado, Dec 15 '16 at 19:01

Mister 832 · Accepted Answer · 2016-12-14T10:15:52.617

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

you can use `With Sheets("Sheet3")` to clean up your code a little — Shai Rado, Dec 14 '16 at 10:59

score 0 · Answer 2 · answered Dec 14 '16 at 14:16

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

Excel VBA - Loop Transpose

2 Answers2

Linked

Related