Transpose Data (Column to Rows)

Hi,

Hope that an expert can help me out with this.

I'm trying to transpose the data shown in the attached example; from a column (Ex:A2:A46) into rows (Ex:C2:Y3).

Problem is that the number of rows being transposed is not a fixed number, only differentiating factor is that the it begins at a 6 digit number and ends in the cell before the next 6 digit number
(Ex:A2:A23 is the data that'll be transposed into the first row & A24:A46 the second row).

There a lot of data in the spreadsheet so if someone can help me with a VBA Macro that can automatically transpose the data, that'll help me a lot!!

Thank you,

Hi Maxpsb47 & welcome to the forum

Try below code based on your sample file ...

Sub test()

Dim a, Lr&

With Range("B1", Range("B" & Rows.Count).End(3))
   a = Filter(Evaluate(Replace("transpose(if(isnumber(@)*(len(@)=6),row(@),false))", "@", .Address)), False, 0)
End With

If UBound(a) > -1 Then
   For x = LBound(a) To UBound(a)
      If x = UBound(a) Then Lr = Range("B" & Rows.Count).End(3).Row - a(x) + 1 Else Lr = a(x + 1) - 2
      Cells(a(x), 2).Resize(Lr).Copy
      Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll, Transpose:=True
   Next
End If
   
End Sub

Originally Posted by Maxpsb47

The macro is not picking up the 6 digit numbers consistently also it looks like data is being duplicated somehow.

Try revised code below ...

Sub test()

Dim a, Lr&

With Range("B1", Range("B" & Rows.Count).End(3))
   a = Filter(Evaluate(Replace("transpose(if(isnumber(@)*(len(@)=6),row(@),false))", "@", .Address)), False, 0)
End With

If UBound(a) > -1 Then
   For x = LBound(a) To UBound(a)
      If x = UBound(a) Then Lr = Range("B" & Rows.Count).End(3).Row Else Lr = a(x + 1) - 1
      Range(Cells(a(x), 2), Cells(Lr, 2)).Copy
      Range("D" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll, Transpose:=True
   Next
End If
   
End Sub

Here is an alternative solution using Power Query.

File is attached. Here is the Mcode

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"EXTRACTED DATA", type any}}),
    #"Replaced Value" = Table.ReplaceValue(#"Changed Type",null,"X",Replacer.ReplaceValue,{"Column1"}),
    #"Added Custom" = Table.AddColumn(#"Replaced Value", "Custom", each if Text.Contains([Column1], "ROW") then [EXTRACTED DATA] else null),
    #"Filled Down" = Table.FillDown(#"Added Custom",{"Custom"}),
    #"Removed Columns" = Table.RemoveColumns(#"Filled Down",{"Column1"}),
    #"Grouped Rows" = Table.Group(#"Removed Columns", {"Custom"}, {{"Data", each _, type table [EXTRACTED DATA=any, Custom=number]}}),
    #"Added Custom1" = Table.AddColumn(#"Grouped Rows", "Custom.1", each Table.AddIndexColumn([Data], "Index", 1, 1)),
    #"Expanded Custom.1" = Table.ExpandTableColumn(#"Added Custom1", "Custom.1", {"EXTRACTED DATA", "Index"}, {"Custom.1.EXTRACTED DATA", "Custom.1.Index"}),
    #"Removed Columns1" = Table.RemoveColumns(#"Expanded Custom.1",{"Data"}),
    #"Filtered Rows" = Table.SelectRows(#"Removed Columns1", each ([Custom.1.Index] <> 1)),
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(#"Filtered Rows", {{"Custom.1.Index", type text}}, "en-US"), List.Distinct(Table.TransformColumnTypes(#"Filtered Rows", {{"Custom.1.Index", type text}}, "en-US")[Custom.1.Index]), "Custom.1.Index", "Custom.1.EXTRACTED DATA")
in
    #"Pivoted Column"

Power Query is a free AddIn for Excel 2010 and 2013, and is built-in functionality from Excel 2016 onwards (where it is referred to as "Get & Transform Data").

It is a powerful yet simple way of getting, changing and using data from a broad variety of sources, creating steps which may be easily repeated and refreshed. I strongly recommend learning how to use Power Query - it's among the most powerful functionalities of Excel.

- Follow this link to learn how to install Power Query in Excel 2010 / 2013.

- Follow this link for an introduction to Power Query functionality.

- Follow this link for a video which demonstrates how to use Power Query code provided.

Maxpsb47, what's the maximum number of items possible under each number. i.e. How many columns would be enough ?

Edit: Try below code ...

Sub test()

Dim a, x&, i&, y&
a = Range("B2", Range("B" & Rows.Count).End(3))

ReDim b(1 To UBound(a), 1 To 100)
For x = 1 To UBound(a)
   If IsNumeric(a(x, 1)) And Len(a(x, 1)) = 6 Then
      i = i + 1
      b(i, 1) = a(x, 1)
      y = 0
   Else
      y = y + 1
      b(i, y + 1) = a(x, 1)
   End If
Next

Range("D" & Rows.Count).End(3)(2).Resize(UBound(b), UBound(b, 2)) = b

End Sub

In the code I posted in post #11, I am assuming maximum number of columns is 100 which you can change in the below line

ReDim b(1 To UBound(a), 1 To 100)

So does the code work now ?

Glad to help & thanks for the feedback

thanks for the rep and feedback. If you are serious about learning PQ then the book, "M is for (Data) Monkey" by Ken Puls and Miguel Escobar.