transpose VBA

S

shahsavand

Board Regular
Joined
Dec 8, 2014
Messages
74
I would like to transpose columns to rows

Please note that the spreadsheet is quite large.
Current file layout example:

VersionProduct960196029603960496059606960796089609961096119612
BudgetA260058005800580058005800580058005800620062007400
Sales LossA0%44%79%55%20%10%26%7%0%62%0%58%
StockA1292678622942625811102125691033512944152545702152457379
ActualA392042306967594148206291506363947410340181669611
MAXA62401392013920139201392013920139201392013920148801488017760
BudgetB94001480015500161001670017400180001680015600144001320012000
Sales LossB000101100000
StockB58008482162748016932287721358410802723236724249163938026564
ActualB15360220081872817484196641609217204982410672109441397611896
MAXB225603552037200386404008041760432004032037440345603168028800


<colgroup><col style="mso-width-source:userset;mso-width-alt:3035;width:62pt" width="83"> <col style="mso-width-source:userset;mso-width-alt:5668;width:116pt" width="155"> <col style="mso-width-source:userset;mso-width-alt:3035; width:62pt" width="83" span="12"> </colgroup><tbody>
</tbody>

Result:
MonthProductsBudgetActualMAXStockSales Loss
9601A260039206240129260%
9602A5800423013920786244%
9603A5800696713920294279%
9604A5800594113920625855%
9605A58004820139201110220%
9606A58006291139201256910%
9607A58005063139201033526%
9608A5800639413920129447%
9609A5800741013920152540%
9610A6200340114880570262%
9611A6200816614880152450%
9612A7400961117760737958%
9601B94001536022560580080%
9602B148002200835520482160%
9603B1550018728372002748026%
9604B1610017484386401693256%
9605B1670019664400802877228%
9606B1740016092417601358467%
9607B180001720443200108098%
9608B168009824403202723232%
9609B156001067237440367242%
9610B1440010944345602491628%
9611B132001397631680393800%
9612B120001189628800265648%

<colgroup><col style="mso-width-source:userset;mso-width-alt:4498;width:92pt" width="123"> <col style="mso-width-source:userset;mso-width-alt:4498;width:92pt" width="123"> <col style="width:48pt" width="64" span="4"> <col style="mso-width-source:userset;mso-width-alt:2962;width:61pt" width="81"> </colgroup><tbody>
</tbody>
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Open a COPY of your workbook. Press Alt-F11 to open the VBA editor. From the menu, click Insert > Module. Paste the following code into the window that opens:

Rich (BB code): 
Sub Rearrange()
Dim sh1 As Worksheet, sh2 As Worksheet, Dict As Object, ctr As Long, MyData As Variant
Dim c As Long, r As Long, rr As Long, op As Variant, res(1 To 50000, 1 To 1) As String

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.Add 1, "Month|Products|Budget|Actual|MAX|Stock|Sales Loss"
    ctr = 1
    MyData = sh1.Range(sh1.Range("A1"), sh1.Cells(sh1.Cells(Rows.Count, 1).End(xlUp).Row, sh1.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
    
    For c = 3 To UBound(MyData, 2)
        For r = 2 To UBound(MyData) Step 5
            ctr = ctr + 1
            Dict.Add ctr, MyData(1, c) & "|" & MyData(r, 2) & "|" & MyData(r, c) & "|" & MyData(r + 3, c) & _
                                      "|" & MyData(r + 4, c) & "|" & MyData(r + 2, c) & "|" & MyData(r + 1, c)
        Next r
    Next c
    
    sh2.Cells.ClearContents
    op = Dict.items
    ctr = 0
    rr = 1
    For r = 0 To UBound(op)
        ctr = ctr + 1
        res(ctr, 1) = op(r)
        If ctr = 50000 Then
            sh2.Cells(rr, 1).Resize(50000).Value = res
            ctr = 0
            rr = rr + 50000
            Erase res
        End If
    Next r
    sh2.Cells(rr, 1).Resize(50000).Value = res
    
    sh2.Columns("A:A").TextToColumns Destination:=sh2.Range("A1"), DataType:=xlDelimited, _
         Other:=True, OtherChar:="|"
    
    With sh2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=sh2.Range("B2")
        .SortFields.Add Key:=sh2.Range("A2")
        .SetRange sh2.Range("A:G")
        .Header = xlYes
        .Apply
    End With
    Selection.Style = "Percent"
    
End Sub
Sheet1 is where you have your input table, Sheet2 is where you want your output table. Both sheets must exist. The input table is assumed to start in A1, the output table will start in A1. Close the VBA editor with Alt-Q. In Excel, press Alt-F8, choose Rearrange and click Run.

Let us know if this works for you.
 
Upvote 0
Eric W said:
Open a COPY of your workbook. Press Alt-F11 to open the VBA editor. From the menu, click Insert > Module. Paste the following code into the window that opens:

Rich (BB code): 
Sub Rearrange()
Dim sh1 As Worksheet, sh2 As Worksheet, Dict As Object, ctr As Long, MyData As Variant
Dim c As Long, r As Long, rr As Long, op As Variant, res(1 To 50000, 1 To 1) As String

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.Add 1, "Month|Products|Budget|Actual|MAX|Stock|Sales Loss"
    ctr = 1
    MyData = sh1.Range(sh1.Range("A1"), sh1.Cells(sh1.Cells(Rows.Count, 1).End(xlUp).Row, sh1.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
    
    For c = 3 To UBound(MyData, 2)
        For r = 2 To UBound(MyData) Step 5
            ctr = ctr + 1
            Dict.Add ctr, MyData(1, c) & "|" & MyData(r, 2) & "|" & MyData(r, c) & "|" & MyData(r + 3, c) & _
                                      "|" & MyData(r + 4, c) & "|" & MyData(r + 2, c) & "|" & MyData(r + 1, c)
        Next r
    Next c
    
    sh2.Cells.ClearContents
    op = Dict.items
    ctr = 0
    rr = 1
    For r = 0 To UBound(op)
        ctr = ctr + 1
        res(ctr, 1) = op(r)
        If ctr = 50000 Then
            sh2.Cells(rr, 1).Resize(50000).Value = res
            ctr = 0
            rr = rr + 50000
            Erase res
        End If
    Next r
    sh2.Cells(rr, 1).Resize(50000).Value = res
    
    sh2.Columns("A:A").TextToColumns Destination:=sh2.Range("A1"), DataType:=xlDelimited, _
         Other:=True, OtherChar:="|"
    
    With sh2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=sh2.Range("B2")
        .SortFields.Add Key:=sh2.Range("A2")
        .SetRange sh2.Range("A:G")
        .Header = xlYes
        .Apply
    End With
    Selection.Style = "Percent"
    
End Sub
Sheet1 is where you have your input table, Sheet2 is where you want your output table. Both sheets must exist. The input table is assumed to start in A1, the output table will start in A1. Close the VBA editor with Alt-Q. In Excel, press Alt-F8, choose Rearrange and click Run.

Let us know if this works for you.
Click to expand...

you are awesome. yeas its working
 
Upvote 0
Eric W said:
Rich (BB code): 
Sub Rearrange()
Dim sh1 As Worksheet, sh2 As Worksheet, Dict As Object, ctr As Long, MyData As Variant
Dim c As Long, r As Long, rr As Long, op As Variant, res(1 To 50000, 1 To 1) As String

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.Add 1, "Month|Products|Budget|Actual|MAX|Stock|Sales Loss"
    ctr = 1
    MyData = sh1.Range(sh1.Range("A1"), sh1.Cells(sh1.Cells(Rows.Count, 1).End(xlUp).Row, sh1.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
    
    For c = 3 To UBound(MyData, 2)
        For r = 2 To UBound(MyData) Step 5
            ctr = ctr + 1
            Dict.Add ctr, MyData(1, c) & "|" & MyData(r, 2) & "|" & MyData(r, c) & "|" & MyData(r + 3, c) & _
                                      "|" & MyData(r + 4, c) & "|" & MyData(r + 2, c) & "|" & MyData(r + 1, c)
        Next r
    Next c
    
    sh2.Cells.ClearContents
    op = Dict.items
    ctr = 0
    rr = 1
    For r = 0 To UBound(op)
        ctr = ctr + 1
        res(ctr, 1) = op(r)
        If ctr = 50000 Then
            sh2.Cells(rr, 1).Resize(50000).Value = res
            ctr = 0
            rr = rr + 50000
            Erase res
        End If
    Next r
    sh2.Cells(rr, 1).Resize(50000).Value = res
    
    sh2.Columns("A:A").TextToColumns Destination:=sh2.Range("A1"), DataType:=xlDelimited, _
         Other:=True, OtherChar:="|"
    
    With sh2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=sh2.Range("B2")
        .SortFields.Add Key:=sh2.Range("A2")
        .SetRange sh2.Range("A:G")
        .Header = xlYes
        .Apply
    End With
    Selection.Style = "Percent"
    
End Sub
Click to expand...
Eric, sooo many lines of code. :devilish:
A little bit shorter...
Code: 
[table="width: 500"]
[tr]
	[td]Sub RearrangeData()
  Dim R As Long, LC As Long, WS1 As Worksheet, WS2 As Worksheet
  Set WS1 = Sheets("Sheet1")
  Set WS2 = Sheets("Sheet2")
  LC = WS1.Cells(1, Columns.Count).End(xlToLeft).Column
  WS2.Range("A1:G1") = Array("Month", "Products", "Budget", "Actual", "MAX", "Stock", "Sales Loss")
  For R = 2 To WS1.Cells(Rows.Count, "A").End(xlUp).Row Step 5
    With WS2.Cells(Rows.Count, "A").End(xlUp)
      .Offset(1, 2).Resize(LC - 2, 5) = Application.Transpose(Application.Index(WS1.Cells, Evaluate("{" & R & ";" & R + 3 & ";" & R + 4 & ";" & R + 2 & ";" & R + 1 & "}"), Evaluate("COLUMN(C:N)")))
      .Offset(1, 6).Resize(LC - 2).NumberFormat = "0%"
      .Offset(1).Resize(LC - 2) = Application.Transpose(WS1.Range("C1").Resize(, LC - 2))
      .Offset(1, 1).Resize(LC - 2) = WS1.Cells(R, "B").Value
    End With
  Next
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Rick Rothstein said:
Eric, sooo many lines of code. :devilish:
A little bit shorter...
Click to expand...

:pray:

I know no one better at writing concise code and using the built-in functionality of Excel and VBA to its best advantage. I think I need to sell all my electronic gadgets and join a vegan commune somewhere . . .
 
Last edited:
Upvote 0
Eric W said:
:pray:

I know no one better at writing concise code and using the built-in functionality of Excel and VBA to its best advantage. I think I need to sell all my electronic gadgets and join a vegan commune somewhere . . .
Click to expand...

Wow! Thank you for those kind words. Every now and then I get "lucky" and an idea for a different, sometimes concise method of attack for a problem occurs to me... that is all that happened this time. And please, don't sell your computer and run off to a commune... the MrExcel Forum benefits greatly from your inputs, trust me, it does.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA script to transpose 2 columns
Replies
3
Views
810
John Davis
J
V
  • Question
using VBA instead of fomula in the sheet
Replies
0
Views
503
vishal120
V

Forum statistics

Threads
1,215,777
Messages
6,126,838
Members
449,343
Latest member
DEWS2031

Share this page

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