Data Transformation: Transpose Rows into Columns

[bstaaa]

I'm looking to transpose a spreadsheet that consists of a column with an ID for the whole row of data, followed by data fields listed in a typical column/row setup, similar to the table below. And for background, my particular data set has thousands of rows and about 20 or so columns.

[TABLE="width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Field 1[/TD]
[TD]Field 2[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]A[/TD]
[TD]X[/TD]
[TD]345[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]B[/TD]
[TD]Y[/TD]
[TD]123[/TD]
[/TR]
</tbody>[/TABLE]

However, due to a limitation of the system this data will be used in, I need to alter this structure to an alternate format where I list out the ID, the field name, followed by the answer for that field, similar to the following:


[TABLE="width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Field[/TD]
[TD]Answer[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Name[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Field 1[/TD]
[TD]X[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Field 2[/TD]
[TD]345[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Name[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Field 1[/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Field 2[/TD]
[TD]123[/TD]
[/TR]
</tbody>[/TABLE]


So to solve this transformation via VBA I'm thinking I need to do the following:

• transpose the field listing into column 2
• have it fill ID 1 out in front of the transposed field names
• transpose the field data into column 3
• then have it repeat for each subsequent number

Is this the right approach? Any thoughts, ideas, or code examples are greatly appreciated.

 

[JumpingCrab]

I think this will do the trick. Assuming that the data is contained in a named range called "Data".

Public Sub transpose()
    Dim target As Worksheet
    Dim sourceData As Range
    Dim thisDataRow As Long
    Dim thisDataCol As Long
    Dim nrOfRows As Long
    Dim nrOfCols As Long
    Dim thisTargetRow As Long
    
    
    Set sourceData = Range("Data")
    nrOfRows = sourceData.Rows.Count
    nrOfCols = sourceData.Columns.Count
    
    Set target = Worksheets("Sheet2")
    
    thisTargetRow = 1
    With target
        .Cells(thisTargetRow, 1) = "ID"
        .Cells(thisTargetRow, 2) = "Field"
        .Cells(thisTargetRow, 3) = "Answer"
        For thisDataRow = 2 To nrOfRows
            For thisDataCol = 2 To nrOfCols
                thisTargetRow = thisTargetRow + 1
                .Cells(thisTargetRow, 1) = sourceData(thisDataRow, 1)
                .Cells(thisTargetRow, 2) = sourceData(1, thisDataCol)
                .Cells(thisTargetRow, 3) = sourceData(thisDataRow, thisDataCol)
            Next
        Next
    End With
End Sub

Hope this helps.

Cheers.

 

[Fluff]

Another option

Sub CopyTranspose()

   Dim Hdrs As Variant
   Dim Rws As Long
   Dim DataWs As Worksheet
   Dim Cl As Range
   Dim NxtRw As Long
   
   Set DataWs = Sheets("[COLOR=#ff0000]Data[/COLOR]")
   Hdrs = DataWs.Range("B1", DataWs.Cells(1, Columns.Count).End(xlToLeft)).Value
   Rws = UBound(Hdrs, 2)
   With Sheets("[COLOR=#ff0000]new[/COLOR]")
      .Range("A1:C1").Value = Array("ID", "Field", "Answer")
      For Each Cl In DataWs.Range("A2", DataWs.Range("A" & Rows.Count).End(xlUp))
         NxtRw = .Range("A" & Rows.Count).End(xlUp).Offset(1).Row
         .Range("A" & NxtRw).Resize(Rws).Value = Cl.Value
         .Range("B" & NxtRw).Resize(Rws).Value = Application.Transpose(Hdrs)
         .Range("C" & NxtRw).Resize(Rws).Value = Application.Transpose(Cl.Offset(, 1).Resize(, Rws).Value)
      Next Cl
   End With
End Sub

Changing sheet names in red to suit.
This assumes your header is in row 1, with data starting in A2

 

[bstaaa]

This worked perfectly, thank you for your help!

 

[Fluff]

Not sure which of us you're talking to, but glad we could help.

 

[JumpingCrab]

Ditto that