Transpose columns to rows and keep first column

[qontrol]

Hi everyone,

I am looking for a VBA code to transpose my data from multiple columns to multiple rows and keeping the first column.

It looks like this:

[TABLE="width: 308"]
<colgroup><col span="4"></colgroup><tbody>[TR]
[TD]Mat[/TD]
[TD]Sub1[/TD]
[TD]Sub2[/TD]
[TD]Sub3[/TD]
[/TR]
[TR]
[TD="align: right"]1032535001[/TD]
[TD]A1[/TD]
[TD]B1[/TD]
[TD]C1[/TD]
[/TR]
[TR]
[TD="align: right"]1032535002[/TD]
[TD]A2[/TD]
[TD]B2[/TD]
[TD]C2[/TD]
[/TR]
[TR]
[TD="align: right"]1032535003[/TD]
[TD]A3[/TD]
[TD]B3[/TD]
[TD]C3[/TD]
[/TR]
</tbody>[/TABLE]

and should look like this:

[TABLE="width: 154"]
<colgroup><col span="2"></colgroup><tbody>[TR]
[TD="align: right"]1032535001[/TD]
[TD] A1[/TD]
[/TR]
[TR]
[TD="align: right"]1032535001[/TD]
[TD] B1[/TD]
[/TR]
[TR]
[TD="align: right"]1032535001[/TD]
[TD] C1[/TD]
[/TR]
[TR]
[TD="align: right"]1032535002[/TD]
[TD] A2[/TD]
[/TR]
[TR]
[TD="align: right"]1032535002[/TD]
[TD] B2[/TD]
[/TR]
[TR]
[TD="align: right"]1032535002[/TD]
[TD] C2[/TD]
[/TR]
[TR]
[TD="align: right"]1032535003[/TD]
[TD] A3[/TD]
[/TR]
[TR]
[TD="align: right"]1032535003[/TD]
[TD] B3[/TD]
[/TR]
[TR]
[TD="align: right"]1032535003[/TD]
[TD] C3[/TD]
[/TR]
</tbody>[/TABLE]

I can't seem to find this in any transpose macro or I might be doing something wrong..

Can someone explain me how to do this?

Thank you!
Regards

 

[Oeldere]

Sub CONVERTROWSTOCOL_Oeldere_revisted_new()

Dim rsht1 As Long, rsht2 As Long, i As Long, col As Long, wsTest As Worksheet, mr As Worksheet, ms As Worksheet

'check if sheet "ouput" already exist

Const strSheetName As String = "Output"

Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
 
If wsTest Is Nothing Then
    Worksheets.Add.Name = strSheetName
End If

'set the data
                 

Set mr = Sheets("sheet1")                                  'this is the name of the source sheet
 
Set ms = Sheets("Output")                                       'this is the name of the destiny sheet

col = 2
'End set the data

    With ms
     .UsedRange.ClearContents
     .Range("A1:B1").Value = Array("Mat", "value")
    End With
    
    rsht2 = ms.Range("A" & Rows.Count).End(xlUp).Row
    
    
    With mr
          rsht1 = .Range("A" & .Rows.Count).End(xlUp).Row
          For i = 2 To rsht1
                Do While .Cells(1, col).Value <> "" 'And .Cells(I, col).Value <> ""
                rsht2 = rsht2 + 1
               
                ms.Range("A" & rsht2).Value = .Range("A" & i).Value
                
               
                ms.Range("B" & rsht2).Value = .Cells(i, col).Value
         
                col = col + 1
            Loop
            col = 2
        Next
    End With
    
  With ms
  
  
  
  
    .Columns("A:Z").EntireColumn.AutoFit
    
    End With
    
End Sub