VBA to Transpose Data

[jrock8859]

Hi,

I would like a VBA that will transpose the data set like this below. I am at a loss of where to start. I am good with VBA for the basic excel functions but I learn by reverse engineering things.

Columns A,B,C is how I am starting, I want to finish with it looking like Columns F and beyond

Tank you

 

[Legacy 143009]

This will work for your example:

Sub transpose()
    Dim lRow As Integer
    Dim c As Integer
    Dim r As Integer
    c = 6
    r = 1

    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lRow
        If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
            For ii = 0 To 1
                Cells(r, c).Value = Cells(i, 2 + ii).Value
                c = c + 1
            Next
        Else
            c = 6
            r = r + 1
            For ii = 0 To 2
                Cells(r, c).Value = Cells(i, 1 + ii).Value
                c = c + 1
            Next
        End If
    Next
End Sub

 

[DanteAmor]

Hi and welcome to MrExcel!

Here is another macro for you to consider:

Sub TransposeData()
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, n As Long, lr As Long, y As Long
  Dim nrow As Long, ncol As Long
 
  lr = Range("A" & Rows.Count).End(3).Row
  a = Range("A1:C" & lr).Value
  n = Evaluate("=MAX(COUNTIF(A2:A" & lr & ",A2:A" & lr & "))")
  ReDim b(1 To UBound(a, 1), 1 To (n * 2) + 1)
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  y = 1
  b(1, 1) = a(1, 1)
  For i = 2 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 2
      b(y, 1) = a(i, 1)
    End If
   
    nrow = Split(dic(a(i, 1)), "|")(0)
    ncol = Split(dic(a(i, 1)), "|")(1)
   
    b(1, ncol) = a(1, 2)
    b(1, ncol + 1) = a(1, 3)
    b(nrow, ncol) = a(i, 2)
    b(nrow, ncol + 1) = a(i, 3)
   
    ncol = ncol + 2
    dic(a(i, 1)) = nrow & "|" & ncol
   
  Next
 
  Range("F1").Resize(y, UBound(b, 2)).Value = b
End Sub

 

[DanteAmor]

If it's not a lot of data, try this macro:

Sub TransposeData2()
  Dim c As Range, f As Range
  
  For Each c In Range("A2", Range("A" & Rows.Count).End(3))
    Set f = Range("F:F").Find(c.Value, , xlValues, xlWhole)
    If f Is Nothing Then
      Range("F" & Rows.Count).End(3)(2).Resize(1, 3).Value = c.Resize(1, 3).Value
    Else
      Cells(f.Row, Columns.Count).End(1)(1, 2).Resize(1, 2).Value = c.Offset(0, 1).Resize(1, 2).Value
    End If
  Next
End Sub

 

[jrock8859]

This will work for your example:

Sub transpose()
    Dim lRow As Integer
    Dim c As Integer
    Dim r As Integer
    c = 6
    r = 1

    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lRow
        If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
            For ii = 0 To 1
                Cells(r, c).Value = Cells(i, 2 + ii).Value
                c = c + 1
            Next
        Else
            c = 6
            r = r + 1
            For ii = 0 To 2
                Cells(r, c).Value = Cells(i, 1 + ii).Value
                c = c + 1
            Next
        End If
    Next
End Sub

Thank you for this, I have a better understanding on how this functions now. Is there a way to have it run faster if the data set is rather large, say a couple hundred rows?

 

[Legacy 143009]

Using arrays may help. Also consider to turn off and on screen update.

Sub transpose()
  Application.ScreenUpdating = False
  // Code here
  Application.ScreenUpdating = True
End Sub

@DanteAmor 's dictionary solution might be faster.

 

[jrock8859]

Hi and welcome to MrExcel!

Here is another macro for you to consider:

Sub TransposeData()
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, n As Long, lr As Long, y As Long
  Dim nrow As Long, ncol As Long
 
  lr = Range("A" & Rows.Count).End(3).Row
  a = Range("A1:C" & lr).Value
  n = Evaluate("=MAX(COUNTIF(A2:A" & lr & ",A2:A" & lr & "))")
  ReDim b(1 To UBound(a, 1), 1 To (n * 2) + 1)
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  y = 1
  b(1, 1) = a(1, 1)
  For i = 2 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 2
      b(y, 1) = a(i, 1)
    End If
  
    nrow = Split(dic(a(i, 1)), "|")(0)
    ncol = Split(dic(a(i, 1)), "|")(1)
  
    b(1, ncol) = a(1, 2)
    b(1, ncol + 1) = a(1, 3)
    b(nrow, ncol) = a(i, 2)
    b(nrow, ncol + 1) = a(i, 3)
  
    ncol = ncol + 2
    dic(a(i, 1)) = nrow & "|" & ncol
  
  Next
 
  Range("F1").Resize(y, UBound(b, 2)).Value = b
End Sub

Hi Dante,

Thank you for your solution. If you wouldn't mind, for my learning purposes. Let's say I only have 2 columns now instead of 3, how would this effect the vba?

 

[DanteAmor]

for my learning purposes. Let's say I only have 2 columns now instead of 3

I added a * to the changed lines in the macro. By the way, jrock8859's macro is quite fast.

Sub TransposeData_1col()
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i As Long, n As Long, lr As Long, y As Long
  Dim nrow As Long, ncol As Long
  
  lr = Range("A" & Rows.Count).End(3).Row
  a = Range("A1:B" & lr).Value              '*
  n = Evaluate("=MAX(COUNTIF(A2:A" & lr & ",A2:A" & lr & "))")
  ReDim b(1 To UBound(a, 1), 1 To n + 1)    '*
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  y = 1
  b(1, 1) = a(1, 1)
  For i = 2 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 2
      b(y, 1) = a(i, 1)
    End If
    
    nrow = Split(dic(a(i, 1)), "|")(0)
    ncol = Split(dic(a(i, 1)), "|")(1)
    
    b(1, ncol) = a(1, 2)
    'b(1, ncol + 1) = a(1, 3)         '*
    b(nrow, ncol) = a(i, 2)
    'b(nrow, ncol + 1) = a(i, 3)      '*
    
    ncol = ncol + 1                   '*
    dic(a(i, 1)) = nrow & "|" & ncol
    
  Next
  
  Range("F1").Resize(y, UBound(b, 2)).Value = b
End Sub

 

[Legacy 143009]

I added a * to the changed lines in the macro. By the way, jrock8859's macro is quite fast.

Which one is "jrock8859's macro"?

 

[DanteAmor]

Which one is "jrock8859's macro"?

Sorry , I meant Flashbond.