Excel Transponse MACRO

Hello,
can you please help,
I have a table with different columns and different row numbers.
I would like to use a macro code to sort it into columns as sample attached.

The pasting has to start at cell 'A50'

Any help is appreciated,
Thank you.
Sample.xls
W.E.BAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

GrahamSkanRetiredCommented:
You can do that with Copy and Paste. Choose Transpose from the Paste button drop-down menu.
GrahamSkanRetiredCommented:
Sorry, I didn't look at your workbook. I thought it was a simple transpose requirement
Sub ReorganiseSheet()
    Dim sh As Worksheet
    Dim r1 As Integer
    Dim c1 As Integer
    Dim r2 As Integer
    
    Set sh = Worksheets(1)
    r2 = 50
    For c1 = 2 To 6
        For r1 = 3 To 9
            sh.Cells(1, 1).Copy '5030
            sh.Paste Cells(r2, 1)
            
            sh.Cells(1, c1).Copy 'Zone - 01
            sh.Paste Cells(r2, 2)
            
            sh.Cells(2, c1).Copy '309
            sh.Paste Cells(r2, 3)
            
            sh.Cells(r1, 1).Copy '0
            sh.Paste Cells(r2, 4)
            
            sh.Cells(r1, c1).Copy '5
            sh.Paste Cells(r2, 5)
            
            r2 = r2 + 1
        Next r1
    Next c1
    
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
W.E.BAuthor Commented:
Hi Graham,
thank you for your time and help, the code is working, however,
it only works for the sample attached,
I have different numbers of columns and different rows numbers. (I have anywhere between 40-80 columns and 30-50 rows).

Can the code recognize to last Columns - Last Row

Also, how do I set the sheet name to a specific sheet name.
Thank you.
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

GrahamSkanRetiredCommented:
I would expect users who ask  'how-to' questions to have some  knowledge of the subject, so that they could manage minor tweaks like this.

There isn't a guaranteed way of determining where you want the ends to be, however checking for empty cells usually does the job:
Option Explicit

Sub ReorganiseSheet()
    Dim sh As Worksheet
    Dim r1 As Integer
    Dim c1 As Integer
    Dim r2 As Integer
    
    Set sh = Worksheets(1)
    r2 = 50
    c1 = 2
    r1 = 3
    Do
        Do
            sh.Cells(1, 1).Copy '5030
            sh.Paste Cells(r2, 1)
            
            sh.Cells(1, c1).Copy 'Zone - 01
            sh.Paste Cells(r2, 2)
            
            sh.Cells(2, c1).Copy '309
            sh.Paste Cells(r2, 3)
            
            sh.Cells(r1, 1).Copy '0
            sh.Paste Cells(r2, 4)
            
            sh.Cells(r1, c1).Copy '5
            sh.Paste Cells(r2, 5)
            
            r2 = r2 + 1
            r1 = r1 + 1
        Loop Until sh.Cells(r1, 1).Value = ""
        c1 = c1 + 1
    Loop Until sh.Cells(1, c1).Value = ""
    
End Sub

Open in new window

W.E.BAuthor Commented:
Thank you,
I used your initial code, and added
   Dim LastCol As Integer -----------         LastCol =
  Dim LastRow As Long --------       LastRow =
    For c1 = 2 To LastCol  
        For r1 = 3 To LastRow

Much appreciated.
GrahamSkanRetiredCommented:
That is another way of defining the limits of the data. Well done.
Rodney EndrigaData AnalystCommented:
Wass_QA, I know you have a working solution. But I found this to be a fun question for me to try to code.

Here's my solution to your question. This has some assumptions built in, but it does not matter how many rows/columns of data you have in each sheet. Try it out and see if it works for you:

Sub ee_SortData_TRANSPOSE()
Dim rng As Range, ws As Worksheet, l As Long, startPt As Range

Set ws = ActiveSheet    'Update Sheetname as needed
' Assumption: DATA starts at Cell B3 for EVERY SHEET (excludes the Header rows/columns)
Set rng = Range(Cells(3, 2), Cells(Rows.Count, ws.UsedRange.Columns.Count).End(xlUp))
l = Cells(Rows.Count, 1).End(xlUp).Row - 2

Set startPt = Range("A50")    ' Pasting starts at [ CELL A50 ]; update as needed
startPt.Select
For Each cell In rng
    ActiveCell.Value = Cells(1, 1).Value
    ActiveCell.Offset(0, 1).Value = Cells(1, cell.Column).Value
    ActiveCell.Offset(0, 2).Value = Cells(2, cell.Column).Value
    ActiveCell.Offset(0, 3).Value = Cells(cell.Row, 1).Value
    ActiveCell.Offset(0, 4).Value = cell.Value
    ActiveCell.Offset(1, 0).Select
Next cell

l = ws.UsedRange.Rows.Count
Set rng = Range(Cells(startPt.Row, startPt.Column), Cells(l, startPt.Column + 4))
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=Range(Cells(startPt.Row, startPt.Column + 1), Cells(l, startPt.Column + 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
    .SetRange rng
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

' This section will COLOR the cells to the SPECIFIED Format; Starting at specified [ startPt ]
Set rng = Range(Cells(startPt.Row, startPt.Column), Cells(l, startPt.Column))
With rng
    .Interior.Color = RGB(182, 221, 232)
    .HorizontalAlignment = xlCenter
    .ColumnWidth = 11.86
End With
Set rng = Range(Cells(startPt.Row, startPt.Column + 1), Cells(l, startPt.Column + 1))
With rng
    .Interior.Color = RGB(255, 255, 204)
    .ColumnWidth = 11.86
End With
Set rng = Range(Cells(startPt.Row, startPt.Column + 2), Cells(l, startPt.Column + 2))
With rng
    .Font.Color = RGB(255, 0, 0)
    .HorizontalAlignment = xlCenter
    .ColumnWidth = 11.86
End With
Set rng = Range(Cells(startPt.Row, startPt.Column + 3), Cells(l, startPt.Column + 3))
With rng
    .Font.Color = RGB(255, 0, 0)
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
    .ColumnWidth = 11.86
End With
Set rng = Range(Cells(startPt.Row, startPt.Column + 4), Cells(l, startPt.Column + 4))
With rng
    .NumberFormat = "00.00"
    .HorizontalAlignment = xlCenter
    .ColumnWidth = 11.86
End With

Cells(1, 1).Select
End Sub

Open in new window

It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.