Transposing Data

[christianbiker]

Greetings all,

I am hoping someone can help me with transposing. I have used the function within Excel but it doesn;t do what I need. It will be a loop for sure. What I need to do is transpose data horizontally in one worksheet to vertically into another worksheet ensuring that certain formatting/spacing is done simulataneously. I have included a before & after example below. Here are the criteria I need to meet:
- The top line is the name...it needs to be bold
- If there are blank cells on a given row I need them ignored with no lines between the data when transposed vertically
- The examples should provide everything else I need by way of visual

Before

Excel Workbook
	E	F	G	H	I	J	K
3	Clark, Jim	32 Wilson St.	Townsend	LW5 1W6
4	King, Chris & Mary	15 Prospect St.	Toronto	LW5 1W6	555-555-5555	555-555-5555	555-555-5555
5	Knoop, Oliver
6	Morningstar, Rob & Lisa	21 King St.	St. Catharines	LW5 1W5	555-555-5555	555-555-5555	555-555-5555
7	Snodgrass, Mark & Ruth	18 Main St.	Mississauga	LW5 1W6	555-555-5555
8	Turner, Tim & Lisa	5 Main St.	Brampton	LW5 1W6
DATABASE

Excel 2003

Cell Formulas
Range	Formula
E3	=IF(M3="YES", B3 & ", " & C3,"")
E4	=IF(M4="YES", B4 & ", " & C4,"")
E5	=IF(M5="YES", B5 & ", " & C5,"")
E6	=IF(M6="YES", B6 & ", " & C6,"")
E7	=IF(M7="YES", B7 & ", " & C7,"")
E8	=IF(M8="YES", B8 & ", " & C8,"")

After

Excel Workbook
	A	B	C	D	E
1	Clark, Mark		King, Chad & Julie		Knoop, Oliver
2	32 Wilson St.		15 Prospect St.
3	Townsend		Toronto
4	LW5 1W6		LW5 1W6
5			555-555-5555
6
7	Morningstar, Rob & Lisa		Snodgrass, Dave & Ruth		Turner, Rick & Mary Ann
8	21 King St.		18 Main St.		5 Timberglade Dr.
9	St. Catharines		Mississauga		Brampton
10	LW5 1W5		LW5 1W6		LW5 1W6
11	555-555-5555		555-555-5555
DETAILED DIRECTORY

Excel 2003

Using the recorder in Excel this is what I came up with, but this would be very time consuming as people are added.


Sub transpose()
'
' transpose Macro
' Macro recorded 15/04/2011 by Chad King
'

'
Range("E3:K3").Select
Selection.Copy
Sheets("DETAILED DIRECTORY").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, transpose:=True
Range("C1").Select

Sheets("DATABASE").Select
Range("E4:K4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("DETAILED DIRECTORY").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, transpose:=True
Range("E1").Select

Sheets("DATABASE").Select
Range("E5:K5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("DETAILED DIRECTORY").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, transpose:=True
Range("A9").Select

Sheets("DATABASE").Select
Range("E6:K6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("DETAILED DIRECTORY").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, transpose:=True
Range("C9").Select

Sheets("DATABASE").Select
Range("E7:K7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("DETAILED DIRECTORY").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, transpose:=True
Range("E9").Select

Sheets("DATABASE").Select
Range("E8:K8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("DETAILED DIRECTORY").Select
Range("E9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, transpose:=True

Range("A1,C1,E1,A9,C9,E9").Select
Range("E9").Activate
Selection.Font.Bold = True
Range("A1").Select
End Sub


Thanks,
Chad

 

[darth.pathos]

Hey Chad,

It appears you're making mailing labels, would I be correct? If you are, I highly recommend the Avery Mailing Label add-in for Word (http://www.avery.com/avery/en_us/Templates-&-Software/Software/Avery-Wizard-for-Microsoft-Office.htm) - it is by far the simplest tool I've found to create mailing labels, and although you need to use the Avery product, the time and stress this utility will save you is definitely worth it.

If however you are not creating mailing labels but need to do this for some other reason than I can't help you :D

Have a great weekend
Chris

 

[christianbiker]

Nope...not for labels, but thanks. Trying to make a directory for printing based on a spreadsheet.

 

[darth.pathos]

I just tried printing out a sheet of "labels" on regular paper and it works well - don't know though if it's precisely what you're looking for. Given the wizard is free and really, really easy to use, it may be worthwhile to give it a try.

(I should have mentioned that you can format your text etc. as you want, so the bolding of the names is definitely possible).

Let me know if you try it out - regardless, all the best and don't go too crazy with this! LOL

Chris

 

[jc.021286]

Hey there Chad,

Looking at what you are doing perhaps this macro will work for you,

Sub transpose()
'
'Let us start off with a clean slate
Sheets("DETAILED DIRECTORY").Cells.Clear
'
'Let us set up a loop for all items in the database
For a = 3 To Sheets("DATABASE").Cells(60000, 5).End(xlUp).Row
Sheets("DATABASE").Select
Sheets("DATABASE").Range(Cells(a, 5), Cells(a, 9)).Copy

Sheets("DETAILED DIRECTORY").Select
Sheets("DETAILED DIRECTORY").Cells(Application.WorksheetFunction.RoundUp((a - 2) / 3, 0) * 6 - 5, (a Mod 3) + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, transpose:=True
Next a

'Insert formats, column widths and auto fit the columns
Columns("A:C").Select
    Columns("A:C").EntireColumn.AutoFit
    Columns("B:B").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.ColumnWidth = 1.57
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.ColumnWidth = 1.57

'Apply bold fonts
For a = 1 To Sheets("DETAILED DIRECTORY").Cells(60000, 1).End(xlUp).Row / 6 + 1
    Rows(a * 6 - 5).Font.Bold = True
Next a
End Sub

Hope this helps,
Sincerely,
jc

 

[christianbiker]

No it is not what I want...thanks for trying.

I need to keep everything in Excel and do not want to use Word. It would be easier to use a macro button...once click, done! I also need to print it in PDF if needed and possibly add graphics.

Other users may be part of this that wouldn't know how to use mail merge. I need to keep it simple.

 

[christianbiker]

jc....

WOW!!! AWESOME!

Works great. As I am playing with it I am wondering if it is possible to set this up to only grab information if there is a YES in column N, and ignore any row without a yes in column N?

I did make 1 minor modification to your code. I set up the columns that contain the data to a set width & centered as well. This way it is uniform on the page and fits the way I want it. See below:

Thanks again!

Sub transpose()

Application.ScreenUpdating = False

'Let us start off with a clean slate
Sheets("DETAILED DIRECTORY").Cells.Clear
'
'Let us set up a loop for all items in the database
For a = 3 To Sheets("DATABASE").Cells(10000, 5).End(xlUp).Row
Sheets("DATABASE").Select
Sheets("DATABASE").Range(Cells(a, 5), Cells(a, 9)).Copy

Sheets("DETAILED DIRECTORY").Select
Sheets("DETAILED DIRECTORY").Cells(Application.WorksheetFunction.RoundUp((a - 2) / 3, 0) * 6 - 5, (a Mod 3) + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, transpose:=True
Next a

'Insert formats, column widths and auto fit the columns
Columns("A:C").Select
Columns("A:C").Select
Selection.ColumnWidth = 30
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 2
Columns("D:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 2

'Apply bold fonts
For a = 1 To Sheets("DETAILED DIRECTORY").Cells(1000, 1).End(xlUp).Row / 6 + 1
Rows(a * 6 - 5).Font.Bold = True
Next a

Cells.Select
With Selection
.HorizontalAlignment = xlCenter
End With

Range("A1").Select

Application.ScreenUpdating = True
End Sub

 

[jc.021286]

sure thing,

Would you rather a blank space holder? Or for it to collapse and if you had 2 no's and 28 yes, the 2 no's are beside each other.

I'd have to rewrite it to include a new variable, probably "b" to keep track of skipped items.

Let me know whch option is preferential,
jc

 

[christianbiker]

Thanks for your response jc!

What I would like is to transpose only the data as originally set out in your formula (columns 5 - 9) that has a "YES" in column N. For all other rows the cell in column N would simply be empty.

I could have the option of the user being forced to select "YES" or "NO" in column N, but in any case I would like the same result. Instead of ignoring a blank cell, the macro would ignore each row that contains the word "NO" in column N.

I hope this answers your question.

Thanks again for your help!

Chad

 

[jc.021286]

Hey there Chad,

I've added my other variable, where you can see that I utilize an IF statement combined with a new variable for my placement of the fields in the Detailed sheet.

Currently it is looking for "Yes", blank, no, ERROR, DIV/0, YES,YEs, yes, would all be skipped from column 14 of the database (Column "N")

Hope this works for you,
Sincerely,
jc

Sub transpose()

Application.ScreenUpdating = False
Dim a, b As Integer
'Let us start off with a clean slate
Sheets("DETAILED DIRECTORY").Cells.Clear
'
'Let us set up a loop for all items in the database
b = 3
For a = 3 To Sheets("DATABASE").Cells(10000, 5).End(xlUp).Row
If Sheets("DATABASE").Cells(a, 14) = "Yes" Then
    Sheets("DATABASE").Select
    Sheets("DATABASE").Range(Cells(a, 5), Cells(a, 9)).Copy
    
    Sheets("DETAILED DIRECTORY").Select
    Sheets("DETAILED DIRECTORY").Cells(Application.WorksheetFunction.RoundUp((b - 2) / 3, 0) * 6 - 5, (b Mod 3) + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, transpose:=True
    b = b + 1
End If
Next a

'Insert formats, column widths and auto fit the columns
Sheets("DETAILED DIRECTORY").Select
Columns("A:C").Select
Columns("A:C").Select
Selection.ColumnWidth = 30
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 2
Columns("D:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 2

'Apply bold fonts
For a = 1 To Sheets("DETAILED DIRECTORY").Cells(1000, 1).End(xlUp).Row / 6 + 1
Rows(a * 6 - 5).Font.Bold = True
Next a

Cells.HorizontalAlignment = xlCenter


Range("A1").Select

Application.ScreenUpdating = True
End Sub