Transpose Macro (Vertical to Horizontal) for a varying Number of rows to varying number of columns.

biostatistician · Oct 24, 2014

Hi all,
New this forum. I'm not a VB expert but did some work with VB years ago back in graduate school so I'm not too familiar anymore.

I'm basically trying to take Column G, and transpose it accordingly. For example, STUDY #2 has 3 extra rows in Column G which I want to transpose to ROW K and onward.
I want to do the same for Study 3 and 4 and so on for almost 3000 STUDY #'s. But the number of rows vary. Is there a code to do this? I know it will be conditional and I need the code to realize it's finished transposing for that STUDY # once the next STUDY appears. I've posted an example of what I'm looking for below. Any help with this would be greatly appreciated!

WHAT I HAVE:

A B C D E F G H I J K L

STUDY

Present

Gen

Number

race

short

diag

Ad

Di

Re

1

Y

F

30

O

81200

81201

M

**

2

Y

M

20

J

83410

83412

O

**

30501

E8888

E8498

3

Y

M

40

B

80230

80235

S

Y

E9688

E8495

4

Y

M

50

B

81510

81514

S

**

8832

E9174

E8498

71894

9556

5

N

F

25

M

82382

82302

S

O

Y

8082

8056

2851

81201

920

85011

E8147

E8495

4019

2724

WHAT I NEED:

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

STUDY

Present

Gen

Number

race

short

diag

Ad

Di

Re

1

Y

F

30

O

81200

81201

M

**

2

Y

M

20

J

83410

83412

O

**

30501

E8888

E8498

3

Y

M

40

B

80230

80235

S

Y

E9688

E8495

4

Y

M

50

B

81510

81514

S

**

8832

E9174

E8498

71894

9556

5

N

F

25

M

82382

82302

S

O

Y

8082

8056

2851

81201

920

85011

E8147

E8495

4019

2724

MickG · Oct 24, 2014

Try this:-
NB:- This code will delete the Blank rows !!!

Code:

[COLOR="Navy"]Sub[/COLOR] MG24Oct57
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng2 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Lst = Range("G" & Rows.Count).End(xlUp).Row
[COLOR="Navy"]Set[/COLOR] Rng2 = Range("F2").Resize(Lst).SpecialCells(xlCellTypeBlanks)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng2.Areas
    Dn.Offset(, 1).Copy
    Dn(1).Offset(-1, 5).PasteSpecial Transpose:=True
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]If[/COLOR] Not Rng2 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] Rng2.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

biostatistician · Oct 24, 2014

MickG said:

Try this:-
NB:- This code will delete the Blank rows !!!

Code:

[COLOR=Navy]Sub[/COLOR] MG24Oct57
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Rng2 [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Lst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
Lst = Range("G" & Rows.Count).End(xlUp).Row
[COLOR=Navy]Set[/COLOR] Rng2 = Range("F2").Resize(Lst).SpecialCells(xlCellTypeBlanks)
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng2.Areas
    Dn.Offset(, 1).Copy
    Dn(1).Offset(-1, 5).PasteSpecial Transpose:=True
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]If[/COLOR] Not Rng2 [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] Rng2.EntireRow.Delete
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Hi Mick,

Thanks for the code. unfortunately the code doesn't run and the debug highlights this line:

Sub MG24Oct57()
Dim Rng As Range, Dn As Range
Dim Rng2 As Range
Dim Lst As Long
Lst = Range("G" & Rows.Count).End(xlUp).Row
Set Rng2 = Range("F2").Resize(Lst).SpecialCells(xlCellTypeBlanks)
For Each Dn In Rng2.Areas
Dn.Offset(, 1).Copy
Dn(1).Offset(-1, 5).PasteSpecial Transpose:=True
Next Dn
If Not Rng2 Is Nothing Then Rng2.EntireRow.Delete
End Sub

It says no cells were found.

Thanks again Mick!

hiker95 · Oct 24, 2014

biostatistician,

This is a duplicate post?

I have change the format of the titles in row 1 to fit the results correctly in the MrExcel display area.

Sample raw data:

Excel 2007

A

B

C

D

E

F

G

H

I

J

K

1

STU DY

Pres ent

Gen

Num ber

race

short

diag

Ad

Di

Re

2

1

Y

F

30

O

81200

81201

M

**

3

2

Y

M

20

J

83410

83412

O

**

4

30501

5

E8888

6

E8498

7

3

Y

M

40

B

80230

80235

S

Y

8

E9688

9

E8495

10

4

Y

M

50

B

81510

81514

S

**

11

8832

12

E9174

13

E8498

14

71894

15

9556

16

5

N

F

25

M

82382

82302

S

O

Y

17

8082

18

8056

19

2851

20

81201

21

920

22

85011

23

E8147

24

E8495

25

4019

26

2724

27

Sheet1

After the macro:

Excel 2007

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

1

STU DY

Pres ent

Gen

Num ber

race

short

diag

Ad

Di

Re

2

1

Y

F

30

O

81200

81201

M

**

3

2

Y

M

20

J

83410

83412

O

**

30501

E8888

E8498

4

3

Y

M

40

B

80230

80235

S

Y

E9688

E8495

5

4

Y

M

50

B

81510

81514

S

**

8832

E9174

E8498

71894

9556

6

5

N

F

25

M

82382

82302

S

O

Y

8082

8056

2851

81201

920

85011

E8147

E8495

4019

2724

7

Sheet1

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:

Sub ReorgData()
' hiker95, 10/24/2014, ME913833
Dim r As Long, lr As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "G").End(xlUp).Row
On Error Resume Next
With Range("F2:F" & lr)
  .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
  .Value = .Value
End With
On Error GoTo 0
For r = 2 To lr
  n = Application.CountIf(Columns(6), Cells(r, 6).Value)
  If n > 1 Then
    Cells(r, 11).Resize(, n - 1).Value = Application.Transpose(Range("G" & r + 1 & ":G" & r + 1 + n - 1).Value)
    Cells(r + 1, 6).Resize(n - 1, 2).ClearContents
  End If
  r = r + n - 1
Next r
Columns.AutoFit
On Error Resume Next
Range("A2:A" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
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.

MickG · Oct 25, 2014

Have a look at this example:-
https://app.box.com/s/794bcp2bs4qierqq2vln

biostatistician · Oct 25, 2014

MickG said:
Have a look at this example:-
https://app.box.com/s/794bcp2bs4qierqq2vln

Thanks Mike for the file! Ah, okay it works for the file you sent me. Don't hate me but I think I figured out what was wrong. I had identifying information on that excel so I forgot I deleted some columns for the post. Obviously that would create an error. There are 5 columns between E and G. Column G in this case is M, and Column F is L. Again it would be column M I'm interested in transposing. I tried working with the code to change G-->M and F-->L, and I set the offset still at 5. But that didn't work. What should I tweak in the code? THanks again for your help Mike and Hiker95!

A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	STU DY	Pres ent	Gen	Num ber	race	source	priority	date	ddate	los	short	diag	Ad	Di	Re
2	1	Y	F	30	O	12	234	324	5234	213	81200	81201	M	M	**
3	2	Y	M	20	J	31	532	325	235	325	83410	83412	O	O	**
4												30501
5												E8888
6												E8498
7	3	Y	M	40	B	23	523	532	213	123	80230	80235	S	S	Y
8												E9688
9												E8495
10	4	Y	M	50	B	53	12	213	35	231	81510	81514	S	S	**
11												8832
12												E9174
13												E8498
14												71894
15												9556
16	5	N	F	25	M	234	645	56345	342	234	82382	82302	S	O	Y
17												8082
18												8056
19												2851
20												81201
21												920
22												85011
23												E8147
24												E8495
25												4019
26												2724
27

hiker95 · Oct 25, 2014

biostatistician,

If the following is a screenshot of the new raw data:

Excel 2007

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

1

STU DY

Pres ent

Gen

Num ber

race

sou rce

pri ority

date

d date

los

short

diag

Ad

Di

Re

2

1

Y

F

30

O

12

234

324

5234

213

81200

81201

M

**

3

2

Y

M

20

J

31

532

325

235

325

83410

83412

O

**

4

30501

5

E8888

6

E8498

7

3

Y

M

40

B

23

523

532

213

123

80230

80235

S

Y

8

E9688

9

E8495

10

4

Y

M

50

B

53

12

213

35

231

81510

81514

S

**

11

8832

12

E9174

13

E8498

14

71894

15

9556

16

5

N

F

25

M

234

645

56345

342

234

82382

82302

S

O

Y

17

8082

18

8056

19

2851

20

81201

21

920

22

85011

23

E8147

24

E8495

25

4019

26

2724

27

Sheet1

Then after the new macro (in two screenshots to fit the display area):

Excel 2007

A

B

C

D

E

F

G

H

I

J

K

L

M

1

STU DY

Pres ent

Gen

Num ber

race

sou rce

pri ority

date

d date

los

short

diag

2

1

Y

F

30

O

12

234

324

5234

213

81200

81201

3

2

Y

M

20

J

31

532

325

235

325

83410

83412

4

7

3

Y

M

40

B

23

523

532

213

123

80230

80235

5

10

4

Y

M

50

B

53

12

213

35

231

81510

81514

6

16

5

N

F

25

M

234

645

56345

342

234

82382

82302

7

Sheet1

Excel 2007

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

1

short

diag

Ad

Di

Re

2

81200

81201

M

**

3

83410

83412

O

**

30501

E8888

E8498

4

80230

80235

S

Y

E9688

E8495

5

81510

81514

S

**

8832

E9174

E8498

71894

9556

6

82382

82302

S

O

Y

8082

8056

2851

81201

920

85011

E8147

E8495

4019

2724

7

Sheet1

Code:

Sub ReorgData_V2()
' hiker95, 10/25/2014, ME913833
Dim r As Long, lr As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "M").End(xlUp).Row
On Error Resume Next
With Range("L2:L" & lr)
  .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
  .Value = .Value
End With
On Error GoTo 0
For r = 2 To lr
  n = Application.CountIf(Columns(12), Cells(r, 12).Value)
  If n > 1 Then
    Cells(r, 17).Resize(, n - 1).Value = Application.Transpose(Range("M" & r + 1 & ":M" & r + 1 + n - 1).Value)
    Cells(r + 1, 12).Resize(n - 1, 2).ClearContents
  End If
  r = r + n - 1
Next r
Columns.AutoFit
On Error Resume Next
Range("B2:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Then un

hiker95 · Oct 25, 2014

biostatistician,

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:

Sub ReorgData_V2()
' hiker95, 10/25/2014, ME913833
Dim r As Long, lr As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "M").End(xlUp).Row
On Error Resume Next
With Range("L2:L" & lr)
  .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
  .Value = .Value
End With
On Error GoTo 0
For r = 2 To lr
  n = Application.CountIf(Columns(12), Cells(r, 12).Value)
  If n > 1 Then
    Cells(r, 17).Resize(, n - 1).Value = Application.Transpose(Range("M" & r + 1 & ":M" & r + 1 + n - 1).Value)
    Cells(r + 1, 12).Resize(n - 1, 2).ClearContents
  End If
  r = r + n - 1
Next r
Columns.AutoFit
On Error Resume Next
Range("B2:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
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_V2 macro.

biostatistician · Oct 25, 2014

hiker95 said:
biostatistician,

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:

Sub ReorgData_V2() ' hiker95, 10/25/2014, ME913833 Dim r As Long, lr As Long, n As Long Application.ScreenUpdating = False lr = Cells(Rows.Count, "M").End(xlUp).Row On Error Resume Next With Range("L2:L" & lr) .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C" .Value = .Value End With On Error GoTo 0 For r = 2 To lr n = Application.CountIf(Columns(12), Cells(r, 12).Value) If n > 1 Then Cells(r, 17).Resize(, n - 1).Value = Application.Transpose(Range("M" & r + 1 & ":M" & r + 1 + n - 1).Value) Cells(r + 1, 12).Resize(n - 1, 2).ClearContents End If r = r + n - 1 Next r Columns.AutoFit On Error Resume Next Range("B2:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 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_V2 macro.

Hiker95,
So i plugged in the code, and didn't get a debug error. But....Excel crashes every time I hit run! No idea why. I waited about 15 minutes hoping it was still running, but nothing. Any idea why this may be the case? I tried it on a very small subset of data as well and the same thing happens with only 50 rows. I tried it with about 10,000 rows too and same thing.

Rick Rothstein · Oct 25, 2014

Here is another macro that you can try...

Code:

Sub TransposeDiagData()
  Dim Blanks As Range, Ar As Range
  On Error GoTo NoBlanks
  Set Blanks = Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlBlanks)
  For Each Ar In Intersect(Blanks.EntireRow, Columns("M")).Areas
    Intersect(Ar(1).Offset(-1).EntireRow, Columns("Q")).Resize(, Ar.Count) = Application.Transpose(Ar)
  Next
  Blanks.EntireRow.Delete
NoBlanks:
End Sub

Transpose Macro (Vertical to Horizontal) for a varying Number of rows to varying number of columns.

biostatistician

New Member

Excel Facts

MickG

MrExcel MVP

biostatistician

New Member

hiker95

Well-known Member

MickG

MrExcel MVP

biostatistician

New Member

hiker95

Well-known Member

hiker95

Well-known Member

biostatistician

New Member

Rick Rothstein

MrExcel MVP

Similar threads

Forum statistics

Share this page

Transpose Macro (Vertical to Horizontal) for a varying Number of rows to varying number of columns.

New Member

Excel Facts

MrExcel MVP

New Member

Well-known Member

MrExcel MVP

New Member

Well-known Member

Well-known Member

New Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock