Move x cells in rows to single column

[moose2210]

hi all

I have this table an i need to convert it to two column

header 1 data1 data2 data3 data4 data5 data6
header 2 fra1 fra2 fra3 fra4 fra5 fra6 fra7
header 3 gres1 gres2 gres3 gres4 gres5

convert to

header 1 data1
header 1 data2
header 1 data3
etc

thanks

 

[JackDanIce]

Assuming header1 is in A1 and data1 is in cell B1, data2 is in cell C1 etc, try:

Sub MoveMe()
 
Dim i As Long, j As Long
 
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
 
With Columns("A:A")
    .Insert shift:=xlToRight
    .Insert shift:=xlToRight
End With

k = 1
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
    j = 4
    Do While Not IsEmpty(Cells(i, j))
        Range("A" & k) = Cells(i, 3)
        Range("B" & k) = Cells(i, j)
        Cells(i, j).ClearContents
        j = j + 1
        k = k + 1
    Loop
    Cells(i, 3).ClearContents
Next i
 
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
 
End Sub