Macro help: Transpose base on column

[harky]

This is how my data is

This is the result
The Macro will Transpose COL AG (Font format had to retain (like colour, bold or underline)

I had get 1 bro to help me but the code will auto fill in other row..

Macro help: Transpose row to column & Copy, paste data

Hi, i need some help. But not sure if someone able to help me. I using excel 2010. This is how my data is The Macro will Transpose COL E (Font format had to retain (like colour, bold or underline) Once transpose, marco will copy and paste the main row data and fill up the blank. (like u...

www.mrexcel.com

Sub Step2_Transpose2()

Dim Lst As Long, Lstcol As Long, n As Long

    'START of confirmation message box'
    response = MsgBox("Run Macro for" & vbNewLine & "Step 2: Transpose?", vbYesNo)
    If response = vbNo Then
    MsgBox ("Macro Canceled!")
    Exit Sub
    End If
    'END of confirmation message box'

Application.ScreenUpdating = False
Lst = Range("C" & Rows.Count).End(xlUp).Row '<- modify 'C' (refer to BS Code Cell)

For n = Lst To 4 Step -1
    Lstcol = Cells(n, Columns.Count).End(xlToLeft).Column - 33 '<- modify "- 6" to svc col (count from col A)
    With Cells(n, 1).EntireRow
        If Lstcol > 0 Then
            .Copy
            Cells(n + 1, 1).Resize(Lstcol).EntireRow.Insert shift:=xlDown
            Cells(n, 34).Resize(, Lstcol).Copy '<- modify '7', count from col A to svc col and +1 (eg. 6+1 =7)
            Cells(n + 1, 33).PasteSpecial Transpose:=True '<- modify '6' (count from col A to svc col)
        End If
End With
Next n

Columns("AH:AZ").EntireColumn.Delete  '<- Delete from Col G after transposed (modify if u change col)
Application.ScreenUpdating = True


        Columns.AutoFit
        Rows.AutoFit

    'START MSG'
      MsgBox "Transpose Completed!"
      Exit Sub
    'End MSG'


End Sub

 

[alansidman]

You could do an Unpivot in Power Query, but it will not keep the colors.

 

[harky]

i had thousand data. This 2 is just sample

You could do an Unpivot in Power Query, but it will not keep the colors.

 

[alansidman]

PQ can handle million lines of data, but the choice is yours. Good luck seeking another answer.

 

[harky]

Hi Thanks. I manage to find my ans for my question.
remove .Copy

Sub Transpose()

Dim Lst As Long, Lstcol As Long, n As Long

    'START of confirmation message box'
    response = MsgBox("Run Macro for" & vbNewLine & "Step 2: Transpose?", vbYesNo)
    If response = vbNo Then
    MsgBox ("Macro Canceled!")
    Exit Sub
    End If
    'END of confirmation message box'

Application.ScreenUpdating = False

Lst = Range("D" & Rows.Count).End(xlUp).Row '<- modify 'D' (refer to BS Code Cell)

For n = Lst To 4 Step -1
    Lstcol = Cells(n, Columns.Count).End(xlToLeft).Column - 33 '<- modify "- 33" to svc col (count from col A)
    With Cells(n, 1).EntireRow
        If Lstcol > 0 Then

'           .Copy
            Cells(n + 1, 1).Resize(Lstcol).EntireRow.Insert shift:=xlDown
            Cells(n, 34).Resize(, Lstcol).Copy '<- modify '34', count from col A to svc col and +1 (eg. 6+1 =7)
            Cells(n + 1, 33).PasteSpecial Transpose:=True '<- modify '33' (count from col A to svc col)
        End If
End With
Next n
Columns("AH:AZ").EntireColumn.Delete  '<- Delete from Col G after transposed (modify if u change col)

Application.ScreenUpdating = True

    Columns.AutoFit
    Rows.AutoFit


    'START MSG'
     MsgBox "Transpose Completed!"
      Exit Sub
    'End MSG'

End Sub