Thread: Macro for transpose

'COLUMNS TO ROWS
Here's a macro for merging rows of data to one row matching for column A.

Columns to Rows - Part 2

There's a sample file to test it on, the same data layout is exactly what you've shown. You could just drop your data into the sample sheet and run it.

haq_enam,

Thanks for starting your own New post.


I assume that your data does not have titles in row 1.


Detach/open workbook ReorgData Area SR ER xlUp - haq_enam - EF776138 - SDG15.xls and run macro ReorgData.



If you want to use the macro on another workbook:


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' stanleydgromjr, 05/16/2011
' http://www.excelforum.com/excel-general/775715-special-transpose.html
' ReorgData Area SR ER xlUp - haq_enam - EF - SDG15.xls
Dim LR As Long, a As Long, SR As Long, ER As Long
Dim Area As Range
Application.ScreenUpdating = False
'If no titles in row 1
With Range("A1")
  .EntireRow.Insert
  .Offset(-1).Value = "A"
End With
LR = Cells(Rows.Count, 1).End(xlUp).Row
For a = LR To 2 Step -1
  If Cells(a, 1) <> Cells(a - 1, 1) Then
    Rows(a).Insert
  End If
Next a
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(4), Unique:=True
Rows(1).Resize(2).Delete
a = 0
For Each Area In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    a = a + 1
    SR = .Row
    ER = SR + .Rows.Count - 1
    If ER - SR = 0 Then
      Cells(a, 5).Value = Cells(SR, 2).Value
    Else
      Cells(a, 5).Resize(, ER - SR + 1).Value = Application.Transpose(Range("B" & SR & ":B" & ER))
    End If
  End With
Next Area
LR = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:B" & LR).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

Before you use the macro, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ReorgData macro.