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:

Mat	Sub1	Sub2	Sub3
1032535001	A1	B1	C1
1032535002	A2	B2	C2
1032535003	A3	B3	C3

<colgroup><col span="4"></colgroup><tbody>
</tbody>

and should look like this:

1032535001	A1
1032535001	B1
1032535001	C1
1032535002	A2
1032535002	B2
1032535002	C2
1032535003	A3
1032535003	B3
1032535003	C3

<colgroup><col span="2"></colgroup><tbody>
</tbody>

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