Transpose macro in excel

E

excel_1317

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

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
Hi,
try using a below Code (I found it on this Forum):
Code: 
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.
 
Last edited:
Upvote 0
hurgadion said:
Hi,
try using a below Code (I found it on this Forum):
Code: 
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.
Click to expand...


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
BCDEFGHIJKLMN
1Company NameAddressPostal CodeTel No.Fax. No.EmailWebsiteContact Name
224 IP LAW GROUP FRANCE48 rue Saint Honor75001 PARISTl : 33 (0) 1 44 88 98 20Fax : 33 (0) 1 44 88 98 46info@24ip.comwww.24ip.comB M Robert HARRISONB Bndicte REBIEREB M Fred SONNENBERG
3AB INITIO5 rue Daunou75002 PARISTl : 33 (0) 1 41 40 00 73Fax : 33 (0) 1 42 66 02 10www.abinitio.euM Lucie DAMBREVILLEM Annick PAIRAULT
4ADSIGNA23 bis rue de Turin75008 PARISTl : 33 (0) 1 45 00 48 48Fax : 33 (0) 1 40 67 95 67www.adsigna.comM Sylvie CAZAUX
5ARMENGAUD AIN3 avenue Bugeaud75116 PARISTl : 33 (0) 1 45 53 05 50Fax : 33 (0) 1 45 53 80 21info@armengaud.frwww.armengaud.frB M Bernard MICHARDIREB Patrick MONLOUISB M Chantal PEAUCELLEM Anne SIEFER-GAILLARDIN
6AUDIC37 rue d'Amsterdam75009 PARISTl : 33 (0) 1 81 29 51 60Fax : 33 (0) 9 50 52 86 32contact@cabinet-audic.frwww.cabinet-audic.frB Herv AUDIC
7B.V.52 rue de la Victoire75440 PARIS CEDEX 09B M Francis BEROGINB M Didier BOULINGUIEZB Eric BURBAUDB M Raphal FLEURANCEB Albert HASSINEM Guylne KIESEL LE COSQUERB Cyra NARGOLWALLAB M Stphane VERDURE
8BAROIS63 avenue Raymond Poincar75016 PARISTl : 33 (0) 1 47 55 98 71Fax : 33 (0) 1 47 55 99 49abarois@wanadoo.frM Alain BAROISBECKER & ASSOCIS25 rue Louis le Grand75002 PARISTl : 33 (0) 1 53 43 85 00Fax : 33 (0) 1 53 43 85 05
9BERNEMAN CONSEILS15 rue Pele75011 PARISTl : 33 (0) 6 80 10 07 17Fax : 33 (0) 1 43 57 01 97danielle.berneman@gmail.comB M Danielle BERNEMAN
Full Document (2)
Excel 2007
 
Upvote 0
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).

Code: 
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
 
Upvote 0
Rick Rothstein said:
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).

Code: 
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
Click to expand...




Works Perfectly!!!! Thank You
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Total of marks with the specific conditions
2
Replies
11
Views
389
Eric W
Eric W
R
  • Solved
How to independently sort multiple columns of this SEQUENCE output without effecting the positions of the columns and of the blanks?
2
Replies
15
Views
459
Rnkhch
R
N
  • Solved
VBA auto fill in information from the list in one sheet to another sheet and save as the excel file.
Replies
5
Views
191
ngochien251088
N
M
  • Question Question
Formulas with Inititals with Last Name
Replies
3
Views
84
Fluff
Fluff
V
  • Question Question
Rank function
2
Replies
12
Views
362
Fluff
Fluff

Forum statistics

Threads
1,223,275
Messages
6,171,122
Members
452,381
Latest member
Nova88

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top