Transpose macro in excel

[excel_1317]

Full Document (2)

	A
2	24 IP LAW GROUP FRANCE
3	48 rue Saint Honoré
4	75001 PARIS
5	Tél : 33 (0) 1 44 88 98 20
6	Fax : 33 (0) 1 44 88 98 46
7	info@24ip.com
8	www.24ip.com
9	B M Robert HARRISON
10	B Bénédicte REBIERE
11	B M Fred SONNENBERG
12
13	AB INITIO
14	5 rue Daunou
15	75002 PARIS
16	Tél : 33 (0) 1 41 40 00 73
17	Fax : 33 (0) 1 42 66 02 10
18	www.abinitio.eu
19	M Lucie DAMBREVILLE
20	M Annick PAIRAULT
21
22	ADSIGNA
23	23 bis rue de Turin
24	75008 PARIS
25	Tél : 33 (0) 1 45 00 48 48
26	Fax : 33 (0) 1 40 67 95 67
27	www.adsigna.com
28	M Sylvie CAZAUX
29
30	ARMENGAUD AINÉ
31	3 avenue Bugeaud
32	75116 PARIS
33	Tél : 33 (0) 1 45 53 05 50
34	Fax : 33 (0) 1 45 53 80 21
35	info@armengaud.fr
36	www.armengaud.fr
37	B M Bernard MICHARDIÈRE
38	B Patrick MONLOUIS
39	B M Chantal PEAUCELLE
40	M Anne SIEFER-GAILLARDIN
41
42	AUDIC
43	37 rue d'Amsterdam
44	75009 PARIS
45	Tél : 33 (0) 1 81 29 51 60
46	Fax : 33 (0) 9 50 52 86 32
47	contact@cabinet-audic.fr
48	www.cabinet-audic.fr
49	B Hervé AUDIC
50
51	B.V.
52	52 rue de la Victoire
53	75440 PARIS CEDEX 09
54	B M Francis BEROGIN
55	B M Didier BOULINGUIEZ
56	B Eric BURBAUD
57	B M Raphaël FLEURANCE
58	B Albert HASSINE
59	M Guylène KIESEL LE COSQUER
60	B Cyra NARGOLWALLA
61	B M Stéphane VERDURE
62
63	BAROIS
64	63 avenue Raymond Poincaré
65	75016 PARIS
66	Tél : 33 (0) 1 47 55 98 71
67	Fax : 33 (0) 1 47 55 99 49
68	abarois@wanadoo.fr
69	M Alain BAROIS
70
71	BECKER & ASSOCIÉS
72	25 rue Louis le Grand
73	75002 PARIS
74	Tél : 33 (0) 1 53 43 85 00
75	Fax : 33 (0) 1 53 43 85 05
76	contact@becker.fr
77	www.becker.fr
78	B Philippe BECKER
79	B Marion CHAJMOWICZ
80	B Valérie GALLOIS
81	B Camille LEBRETTE
82	B M Bénédicte PIERRU
83	B Redha SEKHRI
84	B Anne-Caroline STARCK-LOUDES
85	B Béatrice TEZIER HERMAN
86
87	BERNEMAN CONSEILS
88	15 rue Pelée
89	75011 PARIS
90	Tél : 33 (0) 6 80 10 07 17
91	Fax : 33 (0) 1 43 57 01 97
92	danielle.berneman@gmail.com
93	B M Danielle BERNEMAN

<thead>
</thead><tbody>
</tbody>

Excel 2007





I have many data in above format. I need to put it in columns. Also there is NO uniformity in rows. The data consists of Company name, Address, Tel no. Fax no., email and contact names and in some cases website also.

So when the data is transposed into columns, due to non uniformity the data gets jumbled. PLEASE SUGGEST A WAY THROUGH WHICH THIS DATA CAN BE PUT INTO COLUMNS IN CORRECT FORMAT. Column headinngs as Company name, Address, Tel no. Fax no., email, website and contact name.

 

[hurgadion]

Hi,
try using a below Code (I found it on this Forum):

Sub Transpose_Data()
Dim i&, ar As Range
    
i = 1
For Each ar In Columns("A").SpecialCells(xlConstants).Areas
    i = i + 1
    Cells(i, 2).Resize(, ar.Rows.Count).Value = Application.Transpose(ar)
Next ar
End Sub

Best regards.

 

[excel_1317]

Hi,
try using a below Code (I found it on this Forum):

Sub Transpose_Data()
Dim i&, ar As Range
    
i = 1
For Each ar In Columns("A").SpecialCells(xlConstants).Areas
    i = i + 1
    Cells(i, 2).Resize(, ar.Rows.Count).Value = Application.Transpose(ar)
Next ar
End Sub

Best regards.

Thanks for the code. The code is not giving the desired result. As I mentioned the rows are not uniform. Please see the results that i am getting by above code.

Excel Workbook
	B	C	D	E	F	G	H	I	J	K	L	M	N
1	Company Name	Address	Postal Code	Tel No.	Fax. No.	Email	Website	Contact Name
2	24 IP LAW GROUP FRANCE	48 rue Saint Honor	75001 PARIS	Tl : 33 (0) 1 44 88 98 20	Fax : 33 (0) 1 44 88 98 46	info@24ip.com	www.24ip.com	B M Robert HARRISON	B Bndicte REBIERE	B M Fred SONNENBERG
3	AB INITIO	5 rue Daunou	75002 PARIS	Tl : 33 (0) 1 41 40 00 73	Fax : 33 (0) 1 42 66 02 10	www.abinitio.eu	M Lucie DAMBREVILLE	M Annick PAIRAULT
4	ADSIGNA	23 bis rue de Turin	75008 PARIS	Tl : 33 (0) 1 45 00 48 48	Fax : 33 (0) 1 40 67 95 67	www.adsigna.com	M Sylvie CAZAUX
5	ARMENGAUD AIN	3 avenue Bugeaud	75116 PARIS	Tl : 33 (0) 1 45 53 05 50	Fax : 33 (0) 1 45 53 80 21	info@armengaud.fr	www.armengaud.fr	B M Bernard MICHARDIRE	B Patrick MONLOUIS	B M Chantal PEAUCELLE	M Anne SIEFER-GAILLARDIN
6	AUDIC	37 rue d'Amsterdam	75009 PARIS	Tl : 33 (0) 1 81 29 51 60	Fax : 33 (0) 9 50 52 86 32	contact@cabinet-audic.fr	www.cabinet-audic.fr	B Herv AUDIC
7	B.V.	52 rue de la Victoire	75440 PARIS CEDEX 09	B M Francis BEROGIN	B M Didier BOULINGUIEZ	B Eric BURBAUD	B M Raphal FLEURANCE	B Albert HASSINE	M Guylne KIESEL LE COSQUER	B Cyra NARGOLWALLA	B M Stphane VERDURE
8	BAROIS	63 avenue Raymond Poincar	75016 PARIS	Tl : 33 (0) 1 47 55 98 71	Fax : 33 (0) 1 47 55 99 49	abarois@wanadoo.fr	M Alain BAROIS		BECKER & ASSOCIS	25 rue Louis le Grand	75002 PARIS	Tl : 33 (0) 1 53 43 85 00	Fax : 33 (0) 1 53 43 85 05
9	BERNEMAN CONSEILS	15 rue Pele	75011 PARIS	Tl : 33 (0) 6 80 10 07 17	Fax : 33 (0) 1 43 57 01 97	danielle.berneman@gmail.com	B M Danielle BERNEMAN
Full Document (2)

Excel 2007

 

[Rick Rothstein]

I think this macro (run it from your data sheet) will properly align the transposed data to the output sheet (set the OutputSheet constant... the Const statement... to the actual worksheet you want to output the data to).

Sub RedistributeData()
  Dim X As Long, Z As Long, LastRow As Long, Index As Long, Ar As Range, Data As Variant
  Const OutputSheet As String = "Sheet3"
  Const StartRow As Long = 2
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Set Ar = Columns("A").SpecialCells(xlConstants)
  ReDim Data(1 To Ar.Areas.Count, 1 To 8)
  Index = 1
  For X = 1 To Ar.Areas.Count
    Data(Index, 1) = Ar.Areas(X)(1)
    Data(Index, 2) = Ar.Areas(X)(2)
    Data(Index, 3) = Ar.Areas(X)(3)
    For Z = 4 To Ar.Areas(X).Rows.Count
      If Ar.Areas(X)(Z) Like "Tél : *" Then
        Data(Index, 4) = Mid(Ar.Areas(X)(Z), 7)
      ElseIf Ar.Areas(X)(Z) Like "Fax : *" Then
        Data(Index, 5) = Mid(Ar.Areas(X)(Z), 7)
      ElseIf Ar.Areas(X)(Z) Like "*@*.*" Then
        Data(Index, 6) = Ar.Areas(X)(Z)
      ElseIf Ar.Areas(X)(Z) Like "www.*.*" Then
        Data(Index, 7) = Ar.Areas(X)(Z)
      Else
        Data(Index, 8) = Data(Index, 8) & vbLf & Ar.Areas(X)(Z)
      End If
    Next
    Data(Index, 8) = Mid(Data(Index, 8), 2)
    Index = Index + 1
  Next
  With Worksheets(OutputSheet)
    .Columns("H").WrapText = True
    .Range("A1:H1").Value = Array("Company Name", "Street", "City", "Tel No.", _
                                  "Fax No.", "Email", "Website", "Contact Name")
    .Range("A2:H" & UBound(Data)) = Data
    .Rows.AutoFit
  End With
End Sub

 

[excel_1317]

I think this macro (run it from your data sheet) will properly align the transposed data to the output sheet (set the OutputSheet constant... the Const statement... to the actual worksheet you want to output the data to).

Sub RedistributeData()
  Dim X As Long, Z As Long, LastRow As Long, Index As Long, Ar As Range, Data As Variant
  Const OutputSheet As String = "Sheet3"
  Const StartRow As Long = 2
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Set Ar = Columns("A").SpecialCells(xlConstants)
  ReDim Data(1 To Ar.Areas.Count, 1 To 8)
  Index = 1
  For X = 1 To Ar.Areas.Count
    Data(Index, 1) = Ar.Areas(X)(1)
    Data(Index, 2) = Ar.Areas(X)(2)
    Data(Index, 3) = Ar.Areas(X)(3)
    For Z = 4 To Ar.Areas(X).Rows.Count
      If Ar.Areas(X)(Z) Like "Tél : *" Then
        Data(Index, 4) = Mid(Ar.Areas(X)(Z), 7)
      ElseIf Ar.Areas(X)(Z) Like "Fax : *" Then
        Data(Index, 5) = Mid(Ar.Areas(X)(Z), 7)
      ElseIf Ar.Areas(X)(Z) Like "*@*.*" Then
        Data(Index, 6) = Ar.Areas(X)(Z)
      ElseIf Ar.Areas(X)(Z) Like "www.*.*" Then
        Data(Index, 7) = Ar.Areas(X)(Z)
      Else
        Data(Index, 8) = Data(Index, 8) & vbLf & Ar.Areas(X)(Z)
      End If
    Next
    Data(Index, 8) = Mid(Data(Index, 8), 2)
    Index = Index + 1
  Next
  With Worksheets(OutputSheet)
    .Columns("H").WrapText = True
    .Range("A1:H1").Value = Array("Company Name", "Street", "City", "Tel No.", _
                                  "Fax No.", "Email", "Website", "Contact Name")
    .Range("A2:H" & UBound(Data)) = Data
    .Rows.AutoFit
  End With
End Sub

Works Perfectly!!!! Thank You