Transpose

[kumark1]

Below is my input.


PROD AT1 DESC AT2 DESC AT3 DESC AT4 DESC
fan 1 at 2 sd 6 tf 6 hg
book 9 td 3 hg 4 jh
Look 7 kj 5 ih

OUTPUT SHOULD BE

PROD AT1 DESC
FAN 1 at
FAN 2 sd
FAN 6 tf
FAN 6 hg
book 9 td
book 3 hg
book 4 jh
look 7 kj
look 5 ih



This Should be the output after i run the MACRO

Rows should be Transposed into Columns

 

[hiker95]

kumark1,

Welcome to the MrExcel forum.


Sample raw data in Sheet1:

Excel Workbook
	A	B	C	D	E	F	G	H	I
1	PROD	AT1	DESC	AT2	DESC	AT3	DESC	AT4	DESC
2	fan	1	at	2	sd	6	tf	6	hg
3	book	9	td	3	hg	4	jh
4	Look	7	kj	5	ih
5
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C
1	PROD	AT1	DESC
2	fan	1	at
3	fan	2	sd
4	fan	6	tf
5	fan	6	hg
6	book	9	td
7	book	3	hg
8	book	4	jh
9	Look	7	kj
10	Look	5	ih
11
Results

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()
' hiker95, 03/20/2012
' http://www.mrexcel.com/forum/showthread.php?t=622550
Dim w1 As Worksheet, wR As Worksheet
Dim r As Long, lr As Long, c As Long, lc As Long, nr As Long, n As Long, rr As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
wR.Cells(1, 1).Resize(, 3).Value = w1.Cells(1, 1).Resize(, 3).Value
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr Step 1
  nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
  lc = w1.Cells(r, Columns.Count).End(xlToLeft).Column
  n = (lc - 1) / 2
  wR.Cells(nr, 1).Resize(n).Value = w1.Cells(r, 1).Value
  rr = nr
  For c = 2 To lc Step 2
    wR.Cells(rr, 2).Resize(, 2).Value = w1.Cells(r, c).Resize(, 2).Value
    rr = rr + 1
  Next c
Next r
wR.UsedRange.Columns.AutoFit
wR.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.

 

[kumark1]

Hi ,


Thank you Very much for the Reply

 

[hiker95]

kumark1,

You are very welcome.

Glad I could help.

Come back anytime.