Transpose Value

smartguy

Well-known Member
Joined
Jul 14, 2009
Messages
778
Hello All,

i have excel file in the below format.

Excel Workbook
AB
11 Moulmein Rise9366 8777
2Moulmein RiseSunny Ng
3(Agt) Ecg Property
41 Moulmein Rise9818 0372
51, Moulmein RiseDores
6(Agt) Parkland
716 @ Amber9106 2924
8Amber RdAgt
9Propnex
Old



i need answer in "new"

Answer :

Excel Workbook
ABCD
11 Moulmein Rise9366 8777Sunny Ng(Agt) Ecg Property
2Moulmein Rise
3
41 Moulmein Rise9818 0372Dores(Agt) Parkland
51, Moulmein Rise
6
716 @ Amber9106 2924AgtPropnex
8Amber Rd
new


Please Help Me Provide vba code....
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Hi,

Are there always exactly 3 rows in column B for each pair of values in column A?

M.
 
Upvote 0
smartguy,


Sample raw data in worksheet Old:


Excel Workbook
AB
11 Moulmein Rise9366 8777
2Moulmein RiseSunny Ng
3(Agt) Ecg Property
41 Moulmein Rise9818 0372
51, Moulmein RiseDores
6(Agt) Parkland
716 @ Amber9106 2924
8Amber RdAgt
9Propnex
10
Old





After the macro in a new worksheet New:


Excel Workbook
ABCD
11 Moulmein Rise9366 8777Sunny Ng(Agt) Ecg Property
2Moulmein Rise
3
41 Moulmein Rise9818 0372Dores(Agt) Parkland
51, Moulmein Rise
6
716 @ Amber9106 2924AgtPropnex
8Amber Rd
9
New





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.


Code:
Option Explicit
Sub ReorgData()
' hiker95, 07/04/2012
' http://www.mrexcel.com/forum/showthread.php?644765-Transpose-Value
Dim wO As Worksheet, wN As Worksheet
Dim Area As Range, sr As Long, er As Long, nr As Long
Application.ScreenUpdating = False
Set wO = Worksheets("Old")
If Not Evaluate("ISREF(New!A1)") Then Worksheets.Add(After:=wO).Name = "New"
Set wN = Worksheets("New")
wN.UsedRange.Clear
nr = 1
For Each Area In wO.Range("A1", wO.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    sr = .Row
    er = sr + .Rows.Count - 1
    wN.Range("A" & nr).Resize(er - sr + 1).Value = wO.Range("A" & sr & ":A" & er).Value
    wN.Range("B" & nr).Resize(, er + 1 - sr + 1).Value = Application.Transpose(wO.Range("B" & sr & ":B" & er + 1).Value)
    nr = wN.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
  End With
Next Area
wN.UsedRange.Columns.AutoFit
wN.Activate
Application.ScreenUpdating = True
End Sub


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


Then run the ReorgData macro.
 
Last edited:
Upvote 0
Hi Hiker,

Thanks working fine.

But I Need one small changes..

I Need solution like this.

Please Help...

Anser L

Excel Workbook
ABCDE
11 Moulmein Rise9366 8777Sunny Ng(Agt) Ecg PropertyMoulmein Rise
2
3
41 Moulmein Rise9818 0372Dores(Agt) Parkland1, Moulmein Rise
5
6
716 @ Amber9106 2924AgtPropnexAmber Rd
new
 
Upvote 0
smartguy,


Sample raw data on worksheet Old:


Excel Workbook
AB
11 Moulmein Rise9366 8777
2Moulmein RiseSunny Ng
3(Agt) Ecg Property
41 Moulmein Rise9818 0372
51, Moulmein RiseDores
6(Agt) Parkland
716 @ Amber9106 2924
8Amber RdAgt
9Propnex
10
Old





After the updated macro on the new worksheet New:


Excel Workbook
ABCDE
11 Moulmein Rise9366 8777Sunny Ng(Agt) Ecg PropertyMoulmein Rise
2
3
41 Moulmein Rise9818 0372Dores(Agt) Parkland1, Moulmein Rise
5
6
716 @ Amber9106 2924AgtPropnexAmber Rd
8
New





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).


Code:
Option Explicit
Sub ReorgDataV2()
' hiker95, 07/05/2012
' http://www.mrexcel.com/forum/showthread.php?644765-Transpose-Value
Dim wO As Worksheet, wN As Worksheet
Dim Area As Range, sr As Long, er As Long, nr As Long
Application.ScreenUpdating = False
Set wO = Worksheets("Old")
If Not Evaluate("ISREF(New!A1)") Then Worksheets.Add(After:=wO).Name = "New"
Set wN = Worksheets("New")
wN.UsedRange.Clear
nr = 1
For Each Area In wO.Range("A1", wO.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    sr = .Row
    er = sr + .Rows.Count - 1
    wN.Range("A" & nr).Value = wO.Range("A" & sr).Value
    wN.Range("B" & nr).Resize(, er + 1 - sr + 1).Value = Application.Transpose(wO.Range("B" & sr & ":B" & er + 1).Value)
    wN.Range("E" & nr).Value = wO.Range("A" & er).Value
    nr = wN.Range("A" & Rows.Count).End(xlUp).Offset(3).Row
  End With
Next Area
wN.UsedRange.Columns.AutoFit
wN.Activate
Application.ScreenUpdating = True
End Sub


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


Then run the ReorgDataV2 macro.
 
Upvote 0
smartguy,

Thanks for the feedback.

You are very welcome. Glad I could help.

Come back anytime.
 
Upvote 0

Forum statistics

Threads
1,203,094
Messages
6,053,503
Members
444,667
Latest member
KWR21

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