transpose data from one sheet to another

[maxzoran]

Good morning,

I submitted a thread for this previously but didn't have the proper elements in it to get help. I have a data set that looks similar to the RAW tab in the following file http://www.box.net/shared/fpgqyv9ok3nghx9foqlq

What I need is a formula or a macro to put the data in the form of the TRANSPOSED tab where the "data #" is taken from the headers in columns A and C (1st, 2nd, 3rd...n) then the nth and *nth data is grouped with the "data #." As you can see from the example, the data is not consistent with the number of data sets per group so my trouble lies with ignoring the blanks. I wrote a small nested if statement but quickly realized that it would be a huge formula as my actual data set is much larger than this example. So, I am looking for some help from the infinite wisdom of this board. Any formula tips or macros are sure appreciated.

fyi...I am using Excel 2010

Thanks in advance!

 

[hiker95]

maxzoran,


Thanks for the workbook.


Sample raw data in worksheet RAW (with the data grouped in 10 rows, and a space row between groups):

Excel Workbook
	A	B	C	D
1	1st data	*1st data	2nd data	*2nd data
2	1	A	5	E
3	2	B	6	F
4	3	C	7	G
5	4	D	8	H
6			9	I
7			10	J
8
9
10
11
12	3rd data	*3rd data	4th data	*4th data
13	11	K	14	N
14	12	L	15	O
15	13	M	16	P
16			17	Q
17			18	R
18			19	S
19			20	T
20			21	U
21			22	V
22
23	5th data	*5th data	6th data	*6th data
24	23	W	24	X
25			25	Y
26			26	Z
27			27	AA
28			28	BB
29
30
31
32
33
34	7th data	*7th data	8th data	*8th data
35	29	CC	32	FF
36	30	DD	33	GG
37	31	EE	34	HH
38			35	II
39			36	JJ
40			37	KK
41			38	LL
42
43
44
45	9th data	*9th data	10th data	*10th data
46	39	MM	41	OO
47	40	NN	42	PP
48			43	QQ
49			44	RR
50			45	SS
51			46	TT
52			47	UU
53			48	VV
54			49	WW
RAW

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C
1	data #	Data	*data
2	1	1	A
3	1	2	B
4	1	3	C
5	1	4	D
6	2	5	E
7	2	6	F
8	2	7	G
9	2	8	H
10	2	9	I
11	2	10	J
12	3	11	K
13	3	12	L
14	3	13	M
15	4	14	N
16	4	15	O
17	4	16	P
18	4	17	Q
19	4	18	R
20	4	19	S
21	4	20	T
22	4	21	U
23	4	22	V
24	5	23	W
25	6	24	X
26	6	25	Y
27	6	26	Z
28	6	27	AA
29	6	28	BB
30	7	29	CC
31	7	30	DD
32	7	31	EE
33	8	32	FF
34	8	33	GG
35	8	34	HH
36	8	35	II
37	8	36	JJ
38	8	37	KK
39	8	38	LL
40	9	39	MM
41	9	40	NN
42	10	41	OO
43	10	42	PP
44	10	43	QQ
45	10	44	RR
46	10	45	SS
47	10	46	TT
48	10	47	UU
49	10	48	VV
50	10	49	WW
51
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, 10/09/2011
' http://www.mrexcel.com/forum/showthread.php?t=584276
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, r As Long, rr As Long, c As Long, NR As Long
Dim Sp, MyA As String
Application.ScreenUpdating = False
Set w1 = Worksheets("RAW")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
wR.Range("A1:C1") = [{"data #","Data","*data"}]
LR = w1.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
For r = 1 To LR Step 11
  For c = 1 To 4 Step 2
    Sp = Split(w1.Cells(r, c), " ")
    MyA = Left(Sp(0), Len(Sp(0)) - 2)
    For rr = r + 1 To r + 9 Step 1
      If w1.Cells(rr, c) <> "" Then
        NR = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
        wR.Range("A" & NR) = MyA
        wR.Range("B" & NR).Resize(, 2).Value = w1.Cells(rr, c).Resize(, 2).Value
      End If
    Next rr
  Next c
Next r
wR.Activate
With wR.UsedRange
  .HorizontalAlignment = xlCenter
  .Columns.AutoFit
End With
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.

 

[Rick Rothstein]

Here is another macro for you to consider...

Sub TransposeDataTables()
  Dim LastRow As Long
  Application.ScreenUpdating = False
  With Worksheets("TRANSPOSED")
    .Range("A1").Value = "Data #"
    .Range("B1").Value = "Data"
    .Range("C1").Value = "*Data"
    Worksheets("RAW").Columns("A:B").SpecialCells(xlConstants).Copy .Range("B2")
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    Worksheets("RAW").Columns("C:D").SpecialCells(xlConstants).Copy .Cells(LastRow + 1, "B")
    .Columns("B:C").ClearFormats
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    With .Range("A2:A" & LastRow)
      .FormulaR1C1 = "=IF(COUNTIF(RC2,""*data""),LEFT(RC2,LEN(RC2)-7),"""")"
      .Value = .Value
      .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
      .Value = .Value
    End With
    .Columns("A:C").Sort Range("A1"), xlAscending, Range("B1"), , xlAscending, Range("C1"), xlAscending, xlYes, True
    With .Range("B2:B" & LastRow)
      .Replace "*data", "", xlPart
      .SpecialCells(xlBlanks).EntireRow.Delete
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[maxzoran]

Thanks guys, both work perfectly! Again more awesome help from an awesome forum.

Justin

 

[hiker95]

maxzoran,

You are very welcome.

Glad I could help.

Thanks for the feedback.

Come back anytime.