Code to transpose a data

[Kiran Mambi]

Hi everybody
How are you?

I am stuck up at one place and need the solution.
The data is in sheet1
The required result is in sheet2
The actual data in sheet1 can be of any number of rows.

Thanks
Kiran

[sktneer]

Please find the attached sheet to see if this is what you are trying to achieve.

[oeldere]

@Sktneer

Maybe you could also post your code (in the future) so other forummembers don't have to open the file.

[venkat1926]

copy sheeet1 to sheet3 to preserve original data

try the macro test

Sub test()
Dim j As Integer, k As Integer, p As Integer, q As Integer, r As Integer
Application.ScreenUpdating = False
undo
Worksheets("sheet1").Activate
j = Range("A2").End(xlDown).Row
For k = j To 2 Step -1
    If Cells(k, 7) = "" Then GoTo nextk

    p = Cells(k, 7).End(xlToRight).Column - Cells(k, 6).Column
    'msgbox p
    If p Mod 3 = 0 Then
    p = p / 3
    Else
    p = p / 3 + 1
    End If
    'msgbox p
    q = 7
    
                Range(Cells(k, 1).Offset(1, 0), Cells(k, 1).Offset(p, 0)).EntireRow.Insert

        For r = 1 To p
            Range(Cells(k, q), Cells(k, q).Offset(0, 2)).Cut
            Cells(k + r, "D").Select
            ActiveSheet.Paste
            q = q + 3
        If Cells(k, q) = "" Then Exit For
        
        Next r
     
nextk:
Next k
MsgBox "macro done"
Application.ScreenUpdating = True
End Sub

Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet3").Cells.Copy Worksheets("sheet1").Range("A1")
End Sub

[Kiran Mambi]

Thanks sktneer
the code is working fine and as required.

I would also request venkat1926 to give a sample file since there are two codes.

Thanks again

however the querry is solved but I am waiting for venkat's reply.

[sktneer]

You're welcome. Thanks for the feedback and rep.