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

Status
Not open for further replies.

harky

Active Member
Joined
Apr 8, 2010
Messages
405
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
Hi, i need some help. But not sure if someone able to help me.
I using excel 2010.

This is how my data is
AEYiH3W.jpg


The Macro will Transpose COL E (Font format had to retain (like colour, bold or underline)
OMgE0yG.jpg


Once transpose, marco will copy and paste the main row data and fill up the blank.

(like u see in the pic, which highlighted in yellow are filled up base on the main row.)
Q1WJf3r.jpg


will appreciate someone could help me. thanks million
 
ahh.. i manage to change it :D

Code:
Dim Lst As Long, Lstcol As Long, n As Long
Application.ScreenUpdating = False
Lst = Range("A" & Rows.Count).End(xlUp).Row
For n = Lst To 2 Step -1
    Lstcol = Cells(n, Columns.Count).End(xlToLeft).Column - 7
    With Cells(n, 1).EntireRow
        If Lstcol > 0 Then
            .Copy
            Cells(n + 1, 1).Resize(Lstcol).EntireRow.Insert shift:=xlDown
            Cells(n, 8).Resize(, Lstcol).Copy
            Cells(n + 1, 7).PasteSpecial Transpose:=True
        End If
End With
Next n
Columns("H:S").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Hi, I need some help again... sorry

i added 2 more row, now the code dont work well


bkBzeRt.gif


RLZWPFP.jpg


EFS8Dhz.jpg

Yellow is the part where script will auto fill once is transpose.


Code:
Application.ScreenUpdating = False
Lst = Range("A" & Rows.Count).End(xlUp).Row
For n = Lst To 2 Step -1
    Lstcol = Cells(n, Columns.Count).End(xlToLeft).Column - 6
    With Cells(n, 1).EntireRow
        If Lstcol > 0 Then
            .Copy
            Cells(n + 1, 1).Resize(Lstcol).EntireRow.Insert shift:=xlDown
            Cells(n, 7).Resize(, Lstcol).Copy
            Cells(n + 1, 6).PasteSpecial Transpose:=True
        End If
End With
Next n
Columns("G:S").EntireColumn.Delete
Application.ScreenUpdating = True



You're welcome
You can change that line to any column you like to care of excess data.
 
Last edited:
Upvote 0
Based on your actual data starting "A4", Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG22Aug12
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lstcol [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
Application.ScreenUpdating = False
Lst = Range("C" & Rows.Count).End(xlUp).Row

[COLOR="Navy"]For[/COLOR] n = Lst To 4 [COLOR="Navy"]Step[/COLOR] -1
    Lstcol = Cells(n, Columns.Count).End(xlToLeft).Column - 6
    [COLOR="Navy"]With[/COLOR] Cells(n, 1).EntireRow
        [COLOR="Navy"]If[/COLOR] Lstcol > 0 [COLOR="Navy"]Then[/COLOR]
            .Copy
            Cells(n, 1).Resize(Lstcol).Insert shift:=xlDown
            Cells(n, 7).Resize(, Lstcol).Copy
            Cells(n + 1, 6).PasteSpecial Transpose:=True
           [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] n
Columns("G:W").EntireColumn.Delete
Lst = Range("C" & Rows.Count).End(xlUp).Row
[COLOR="Navy"]Set[/COLOR] Rng = Range("A4").Resize(Lst - 3).SpecialCells(xlCellTypeBlanks)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    Dn.Value = Dn(1).Offset(-1).Value
    Dn.Offset(, 1).Value = Dn(1).Offset(-1, 1).Value
[COLOR="Navy"]Next[/COLOR] Dn
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks! It work!

Based on your actual data starting "A4", Try this:-
Code:
[COLOR=Navy]Sub[/COLOR] MG22Aug12
[COLOR=Navy]Dim[/COLOR] Lst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Lstcol [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range
Application.ScreenUpdating = False
Lst = Range("C" & Rows.Count).End(xlUp).Row

[COLOR=Navy]For[/COLOR] n = Lst To 4 [COLOR=Navy]Step[/COLOR] -1
    Lstcol = Cells(n, Columns.Count).End(xlToLeft).Column - 6
    [COLOR=Navy]With[/COLOR] Cells(n, 1).EntireRow
        [COLOR=Navy]If[/COLOR] Lstcol > 0 [COLOR=Navy]Then[/COLOR]
            .Copy
            Cells(n, 1).Resize(Lstcol).Insert shift:=xlDown
            Cells(n, 7).Resize(, Lstcol).Copy
            Cells(n + 1, 6).PasteSpecial Transpose:=True
           [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]Next[/COLOR] n
Columns("G:W").EntireColumn.Delete
Lst = Range("C" & Rows.Count).End(xlUp).Row
[COLOR=Navy]Set[/COLOR] Rng = Range("A4").Resize(Lst - 3).SpecialCells(xlCellTypeBlanks)
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng.Areas
    Dn.Value = Dn(1).Offset(-1).Value
    Dn.Offset(, 1).Value = Dn(1).Offset(-1, 1).Value
[COLOR=Navy]Next[/COLOR] Dn
Application.ScreenUpdating = True
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi, i had an error

It say Run-time error 1004
No cells were found.

When debug it say this row. Do u know what it mean?

Set Rng = Range("A4").Resize(Lst - 3).SpecialCells(xlCellTypeBlanks)



You're welcome
 
Upvote 0
Hi, i used the same code but this time i dont want to auto fill in the data. Just want to transpose. How to remove the filldown part?

VBA Code:
Dim Lst As Long, Lstcol As Long, n As Long, rng As Range, Dn As Range

    '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).Resize(Lstcol).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)
        Lst = Range("D" & Rows.Count).End(xlUp).Row  '<- C is refer to BS Code Cell (modify if u change col)
        Set rng = Range("A3").Resize(Lst - 3).SpecialCells(xlCellTypeBlanks) 'actual data starting "A2" (modify if u change col)
        For Each Dn In rng.Areas
        Dn.Value = Dn(1).Offset(-1).Value
        Dn.Offset(, 1).Value = Dn(1).Offset(-1, 1).Value
    Next Dn
        Application.ScreenUpdating = True
        
        Columns.AutoFit
        Rows.AutoFit


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

End Sub

Good news !!!
 
Upvote 0
or this code.. how to remove the autofill :D

VBA Code:
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
 
Upvote 0
Status
Not open for further replies.

Forum statistics

Threads
1,213,530
Messages
6,114,163
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top