Transpose rows with variable data into a single column

[sonikshah]

Hi,

I want to break down every row into multiple row where a part of it would be carried forward from the parent and the last column would be the transpose of the remaining part of the parent row. Here's an example.

Table 1 (static column A, B. variable column: C, D, E, F...):
[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD="align: center"]Column A[/TD]
[TD="align: center"]Column B
[/TD]
[TD="align: center"]​Column C[/TD]
[TD="align: center"]​Column D[/TD]
[TD="align: center"]​Column E[/TD]
[TD="align: center"]​Column F[/TD]
[/TR]
[TR]
[TD]abc[/TD]
[TD]def[/TD]
[TD]ABC[/TD]
[TD]DEF[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]lmn[/TD]
[TD]pqr[/TD]
[TD]LMN[/TD]
[TD]PQR[/TD]
[TD]XYZ[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I would want it to look like:
Table 2:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Column A
[/TD]
[TD]Column B[/TD]
[TD]Column C[/TD]
[TD]Column D[/TD]
[TD]Column E[/TD]
[TD]Column F[/TD]
[/TR]
[TR]
[TD]abc
[/TD]
[TD]def[/TD]
[TD]ABC[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]abc[/TD]
[TD]def[/TD]
[TD]DEF[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]lmn[/TD]
[TD]pqr[/TD]
[TD]LMN[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]lmn
[/TD]
[TD]pqr[/TD]
[TD]PQR[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]lmn[/TD]
[TD]pqr[/TD]
[TD]XYZ[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

There are almost a 1000 rows in my original table with the variable part of the rows ranging from 1 to 10 columns. This means that every row's static part can have 1-10 copies with only the last column changing. I hope the problem makes sense. I have looked at other topics in the forum and have found similar topics (transposing rows into single column), however I didn't find one with variable data in the rows, and where they dont have a static part that gets copied. Please help!

Thanks,
Sonik

 

[Andrew Poulsom]

Welcome to MrExcel.

Try (changing the reference to Sheet1 if necessary):

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim ShNew As Worksheet
    Dim x As Integer
    Dim r As Integer
    Dim c As Integer
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A1").CurrentRegion
    Set ShNew = Worksheets.Add
    x = 1
    For r = 1 To Rng.Rows.Count
        For c = 3 To Rng.Columns.Count
            If Rng.Cells(r, c).Value <> "" Then
                ShNew.Cells(x, 1).Value = Rng.Cells(r, 1).Value
                ShNew.Cells(x, 2).Value = Rng.Cells(r, 2).Value
                ShNew.Cells(x, 3).Value = Rng.Cells(r, c).Value
                x = x + 1
            End If
        Next c
    Next r
End Sub

 

[AlphaFrog]

Another one (hated to waist it).

[color=darkblue]Sub[/color] Transposer()
    [color=darkblue]Dim[/color] v [color=darkblue]As[/color] [color=darkblue]Variant[/color], i [color=darkblue]As[/color] [color=darkblue]Long[/color], j [color=darkblue]As[/color] [color=darkblue]Long[/color], k [color=darkblue]As[/color] Long
    v = ActiveSheet.UsedRange.Value
    Worksheets.Add After:=Sheets(Sheets.Count)
    Application.ScreenUpdating = [color=darkblue]False[/color]
    [color=darkblue]For[/color] i = 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](v, 1)
        [color=darkblue]For[/color] j = 3 [color=darkblue]To[/color] [color=darkblue]UBound[/color](v, 2)
            [color=darkblue]If[/color] Len(v(i, j)) [color=darkblue]Then[/color]
                k = k + 1
                Range("A" & k).Value = v(i, 1)
                Range("B" & k).Value = v(i, 2)
                Range("C" & k).Value = v(i, j)
            [color=darkblue]Else[/color]
                [color=darkblue]Exit[/color] [color=darkblue]For[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] j
    [color=darkblue]Next[/color] i
    Application.ScreenUpdating = [color=darkblue]False[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[Rick Rothstein]

Here is anothe macro which, if you have lots of data, should be noticeably fast...

Sub RedistributeDataOnwardFromColumnC()
  Dim R As Long, C As Long, Index As Long, LastRow As Long, LastCol As Long
  Dim ArrIn As Variant, ArrOut As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  LastCol = Rows("1:" & LastRow).Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlValues).Column
  ArrIn = Range("A1").Resize(LastRow, LastCol)
  ReDim ArrOut(1 To LastRow * (LastCol - 2), 1 To LastCol)
  Index = 1
  For R = 1 To LastRow
    For C = 3 To LastCol
      If Len(ArrIn(R, C)) Then
        ArrOut(Index, 1) = ArrIn(R, 1)
        ArrOut(Index, 2) = ArrIn(R, 2)
        ArrOut(Index, 3) = ArrIn(R, C)
        Index = Index + 1
      End If
    Next
  Next
  With Worksheets.Add
    .Range("A1").Resize(UBound(ArrOut), LastCol) = ArrOut
  End With
End Sub

Edit Note: Revised code posted at 2:12pm EDT

 

[sonikshah]

All three of them worked! Thanks a lot!