Help! I need a macro to transpose Multi rows into singles rows

P

PhilLazalde

New Member
Joined
Jul 9, 2010
Messages
7
Hi!
I need help again with a macro to take my data that comes to me in a single column that I can transpose into single rows over multiple columns. Briefly, heres my issue; I have data that im gathering on my companies website that I cut and paste into excel and comes in the following format:

Bill's Wild Graphic
Using Millions of colors
213-621-7775
Los Angeles, Ca
bill.wild@gmail.com
www.billswildgraficcolor.com


The ColorRocker Event
Printers Are We
884-335-0439
Brea Hills, CA

Albert Einstien
Rancho Cucamonga, Ca
aleinstien2@verizon.net

Elvis is Alive
Print Contractors LIC#0003371
(310)407-2649
Riverside, Ca
elvis.alive@yahoo.com

The problem I have is the data is not uniformed, some contain 3, 4, 5 or 6 rows. I need them in a mailist format as I've detailed below (/=each in separate columns) :

Bills wild graphic / Using Millions of colors / 213-621-7775 / Los Angeles, Ca / bill.wild@gmail.com / www.billswildgraficcolor.com

The ColorRocker Event / Printers We Are / 884-335-0439 / Brea Hills, Ca

Albert Enstien / Rancho Cucamonga, Ca / aleinstien2@verizon.net


Elvis is Alive / Print Contractors LIC#0003371 / (310)407-2649 / Riverside, Ca / elvis.alive@yahoo.com[/email]

Can you help? I really need help, as my job depends on me being able to do this. I appreciate anything you can do for me. Please let me know if you need any additional information. Thanks in advance for your help! :confused: :)
 
Last edited:

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
Hi Phil

I can't help you I'm afraid, but I am confident you will get your help, some very clever people on here.

I just thought I'd let you know that I found it funny that your job depends on you getting a solution :LOL:

Regards
manc
 
Upvote 0
PhilLazalde,


Sample data before the macro:


Excel Workbook
ABCDEFGH
1Bill's Wild Graphic
2Using Millions of colors
3213-621-7775
4Los Angeles, Ca
5bill.wild@gmail.com
6www.billswildgraficcolor.com
7
8
9The ColorRocker Event
10Printers Are We
11884-335-0439
12Brea Hills, CA
13
14Albert Einstien
15Rancho Cucamonga, Ca
16aleinstien2@verizon.net
17
18Elvis is Alive
19Print Contractors LIC#0003371
20(310)407-2649
21Riverside, Ca
22elvis.alive@yahoo.com
23
Sheet1





After the macro:


Excel Workbook
ABCDEFGH
1Bill's Wild GraphicBill's Wild GraphicUsing Millions of colors213-621-7775Los Angeles, Cabill.wild@gmail.comwww.billswildgraficcolor.com
2Using Millions of colorsThe ColorRocker EventPrinters Are We884-335-0439Brea Hills, CA
3213-621-7775Albert EinstienRancho Cucamonga, Caaleinstien2@verizon.net
4Los Angeles, CaElvis is AlivePrint Contractors LIC#0003371(310)407-2649Riverside, Caelvis.alive@yahoo.com
5bill.wild@gmail.com
6www.billswildgraficcolor.com
7
8
9The ColorRocker Event
10Printers Are We
11884-335-0439
12Brea Hills, CA
13
14Albert Einstien
15Rancho Cucamonga, Ca
16aleinstien2@verizon.net
17
18Elvis is Alive
19Print Contractors LIC#0003371
20(310)407-2649
21Riverside, Ca
22elvis.alive@yahoo.com
23
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).

Adding the Macro
1. Copy the below macro, by highlighting the macro 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. 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.


Code: 
Option Explicit
Sub ReorgData()
' hiker95, 08/08/2010, ME486942
Dim AArea As Range
Dim SR As Long, ER As Long, NR As Long
Application.ScreenUpdating = False
For Each AArea In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With AArea
    SR = .Row
    ER = SR + .Rows.Count - 1
    NR = NR + 1
    Range("C" & NR).Resize(, ER - SR + 1).Value = Application.Transpose(AArea)
  End With
Next AArea
ActiveSheet.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub


Then run the "ReorgData" macro.
 
Upvote 0
PhilLazalde,


If you need your data to look like this, then I will have to use a different method:


Excel Workbook
CDEFGH
1Bill's Wild GraphicUsing Millions of colors213-621-7775Los Angeles, Cabill.wild@gmail.comwww.billswildgraficcolor.com
2The ColorRocker EventPrinters Are We884-335-0439Brea Hills, CA
3Albert EinstienRancho Cucamonga, Caaleinstien2@verizon.net
4Elvis is AlivePrint Contractors LIC#0003371(310)407-2649Riverside, Caelvis.alive@yahoo.com
5
Sheet1
 
Upvote 0
Hi Hiker!

First of all, thank you! Yes I have to have my data look like the second message you have sent. I need the first row of the new group of data in a new row as detailed below using 1-2-3-4 as new row examples.



1 Bill's Wild Graphic Using Millions of colors 213-621-7775 Los Angeles, Ca bill.wild@gmail.com www.billswildgraficcolor.com
2 The ColorRocker Event Printers Are We 884-335-0439 Brea Hills, CA
3 Albert Einstien Rancho Cucamonga, Ca aleinstien2@verizon.net
4 Elvis is Alive Print Contractors LIC#0003371 (310)407-2649 Riverside, Ca elvis.alive@yahoo.com

Etc....

Thanks!!

Phil
 
Upvote 0
PhilLazalde,


Sample data before the new macro:


Excel Workbook
ABCDEFGH
1Bill's Wild Graphic
2Using Millions of colors
3213-621-7775
4Los Angeles, Ca
5bill.wild@gmail.com
6www.billswildgraficcolor.com
7
8
9The ColorRocker Event
10Printers Are We
11884-335-0439
12Brea Hills, CA
13
14Albert Einstien
15Rancho Cucamonga, Ca
16aleinstien2@verizon.net
17
18Elvis is Alive
19Print Contractors LIC#0003371
20(310)407-2649
21Riverside, Ca
22elvis.alive@yahoo.com
23
Sheet1





After the new macro (based on your posted raw data):


Excel Workbook
ABCDEFGH
1Bill's Wild GraphicBill's Wild GraphicUsing Millions of colors213-621-7775Los Angeles, Cabill.wild@gmail.comwww.billswildgraficcolor.com
2Using Millions of colorsThe ColorRocker EventPrinters Are We884-335-0439Brea Hills, CA
3213-621-7775Albert EinstienRancho Cucamonga, Caaleinstien2@verizon.net
4Los Angeles, CaElvis is AlivePrint Contractors LIC#0003371(310)407-2649Riverside, Caelvis.alive@yahoo.com
5bill.wild@gmail.com
6www.billswildgraficcolor.com
7
8
9The ColorRocker Event
10Printers Are We
11884-335-0439
12Brea Hills, CA
13
14Albert Einstien
15Rancho Cucamonga, Ca
16aleinstien2@verizon.net
17
18Elvis is Alive
19Print Contractors LIC#0003371
20(310)407-2649
21Riverside, Ca
22elvis.alive@yahoo.com
23
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).

Adding the Macro
1. Copy the below macro, by highlighting the macro 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. 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.


Code: 
Option Explicit
Option Base 1
Sub ReorgDataV2()
' hiker95, 08/08/2010, ME486942
Dim AArea As Range, c As Range, firstaddress As String
Dim SR As Long, ER As Long, NR As Long, s As Long, f As Long
Dim MyS
Application.ScreenUpdating = False
MyS = Array("*@*", "www.*", "*-*", "*, *")
For Each AArea In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With AArea
    SR = .Row
    ER = SR + .Rows.Count - 1
    NR = NR + 1
    Range("A" & SR).Copy Range("C" & NR)
    f = 0
    With Range("A" & SR + 1)
      For s = LBound(MyS) To UBound(MyS)
        Set c = .Find(MyS(s), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            Select Case s
              Case 1
                f = f + 1
              Case 2
                f = f + 1
              Case 3
                f = f + 1
              Case 4
                f = f + 1
            End Select
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      Next s
    End With
    If f = 0 Then Range("A" & SR + 1).Copy Range("D" & NR)
    With AArea
      For s = LBound(MyS) To UBound(MyS)
        Set c = .Find(MyS(s), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            Select Case s
              Case 1        '  "@", NR, "G"
                c.Copy Range("G" & NR)
              Case 2        '  "www.*", NR, "H"
                c.Copy Range("H" & NR)
              Case 3        '  "*-*", NR, "E"
                c.Copy Range("E" & NR)
              Case 4        '  ", ", NR, "F"
                c.Copy Range("F" & NR)
            End Select
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      Next s
    End With
  End With
Next AArea
ActiveSheet.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub


Then run the "ReorgDataV2" macro.
 
Upvote 0
Hi Hiker,

It did not work. My spreadsheet starts at A1 and the result was three rows from the very first record and it also copied the email from the last record of the sheet. Let me know if there is anything else you can do. Thanks again!
 
Upvote 0
Hi Hiker,

Attached, is my screen shot. I hope I was clear enough on it. Let me know. Thanks for this, I really appreciate it!


Excel Workbook
ABCDEFGHI
1J.D. Aaamperage License # 01320001
2jdaaamperage@hotmail.com
3Cellular (919) 644-1717
4Laguna Niguel Office
544451 Golden Lanyard, Suite 10
6Laguna Niguel, CA 92576
7
8Steve Garabdo License # 9944166
9stevegarabdo@firstrepsonse.com
10Direct (909) 983-9510
11Cellular (949) 874-2298
12Laguna Hills - Jimbo Suites
1341050 Alisons Crack Rd, Suite 100A
14Laguna Hills, CA 92671
15
16Lynda bivan
17lyndabivan@tagalogwo.com
18Fluent in Tagalog
19Cellular (213) 820-2054
20Fax (310) 470-1088
21Corona -Main Bldg.
228001 Kindard Street, Suite 400
23Corona, CA 92882
24
25
26NAMEEMAILMISC.DIRECT PHONECELL PHONEFAX PHONEOFFICEADDRESSCITY, ST ZIP
27J.D. Aaamperage License # 01320001jdaaamperage@hotmail.comCellular (919) 644-1717Laguna Niguel Office44451 Golden Lanyard, Suite 10Laguna Niguel, CA 92576
28Steve Garabdo License # 9944166stevegarabdo@firstrepsonse.comDirect (909) 983-9510Cellular (949) 874-2298Laguna Hills - Jimbo Suites41050 Alisons Crack Rd, Suite 100ALaguna Hills, CA 92671
29Lynda bivanlyndabivan@tagalogwo.comFluent in TagalogCellular (213) 820-2054Fax (310) 470-1088Corona -Main Bldg.8001 Kindard Street, Suite 400Corona, CA 92882
30
Test Macro
 
Upvote 0
PhilLazalde,


Sample data is always in worksheet Sheet1 before the macro (as depicted with the last three rows in each group in column A that go into columns for "OFFICE", "Address", and "CITY, ST *ZIP":


Excel Workbook
ABCDEFGHIJK
1J.D. Aaamperage License # 01320001
2jdaaamperage@hotmail.com
3Cellular (919) 644-1717
4Laguna Niguel Office
544451 Golden Lanyard, Suite 10
6Laguna Niguel, CA 92576
7
8Steve Garabdo License # 9944166
9stevegarabdo@firstrepsonse.com
10Direct (909) 983-9510
11Cellular (949) 874-2298
12Laguna Hills - Jimbo Suites
1341050 Alisons Crack Rd, Suite 100A
14Laguna Hills, CA 92671
15
16Lynda bivan
17lyndabivan@tagalogwo.com
18Fluent in Tagalog
19Cellular (213) 820-2054
20Fax (310) 470-1088
21Corona -Main Bldg.
228001 Kindard Street, Suite 400
23Corona, CA 92882
24
Sheet1





After the new macro:


Excel Workbook
ABCDEFGHIJK
1J.D. Aaamperage License # 01320001NAMEEmailMISC.DIRECT PHONECELL PHONEFAX PHONEOFFICEAddressCITY, ST *ZIP
2jdaaamperage@hotmail.comJ.D. Aaamperage License # 01320001jdaaamperage@hotmail.comCellular (919) 644-1717Laguna Niguel Office44451 Golden Lanyard, Suite 10Laguna Niguel, CA 92576
3Cellular (919) 644-1717Steve Garabdo License # 9944166stevegarabdo@firstrepsonse.comDirect (909) 983-9510Cellular (949) 874-2298Laguna Hills - Jimbo Suites41050 Alisons Crack Rd, Suite 100ALaguna Hills, CA 92671
4Laguna Niguel OfficeLynda bivanlyndabivan@tagalogwo.comFluent in TagalogCellular (213) 820-2054Fax (310) 470-1088Corona -Main Bldg.8001 Kindard Street, Suite 400Corona, CA 92882
544451 Golden Lanyard, Suite 10
6Laguna Niguel, CA 92576
7
8Steve Garabdo License # 9944166
9stevegarabdo@firstrepsonse.com
10Direct (909) 983-9510
11Cellular (949) 874-2298
12Laguna Hills - Jimbo Suites
1341050 Alisons Crack Rd, Suite 100A
14Laguna Hills, CA 92671
15
16Lynda bivan
17lyndabivan@tagalogwo.com
18Fluent in Tagalog
19Cellular (213) 820-2054
20Fax (310) 470-1088
21Corona -Main Bldg.
228001 Kindard Street, Suite 400
23Corona, CA 92882
24
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: 
Option Explicit
Sub ReorgDataV3()
' hiker95, 08/13/2010, ME486942
' Thank you JBeaucaire
Dim Sht As Worksheet, RNG As Range
Dim Grp As Long, NR As Long, Itm As Long, L As Long
Application.ScreenUpdating = False
Set Sht = Sheets("Sheet1")
Set RNG = Sht.Range("A:A").SpecialCells(xlConstants)
With Sht.Range("C1").Resize(, 9)
  .Value = [{"NAME","Email","MISC.","DIRECT PHONE","CELL PHONE","FAX PHONE","OFFICE","Address","CITY, ST *ZIP"}]
  .Font.Bold = True
End With
NR = Sht.Range("C" & Sht.Rows.Count).End(xlUp).Row + 1
For Grp = 1 To RNG.Areas.Count
  Sht.Range("C" & NR) = RNG.Areas(Grp).Cells(1)
  L = RNG.Areas(Grp).Rows.Count
  Sht.Range("I" & NR) = RNG.Areas(Grp).Cells(L - 2)
  Sht.Range("J" & NR) = RNG.Areas(Grp).Cells(L - 1)
  Sht.Range("K" & NR) = RNG.Areas(Grp).Cells(L)
  For Itm = 2 To RNG.Areas(Grp).Rows.Count - 3
    If InStr(RNG.Areas(Grp).Cells(Itm), "@") > 0 Then
      Sht.Range("D" & NR) = RNG.Areas(Grp).Cells(Itm)
    ElseIf Left(RNG.Areas(Grp).Cells(Itm), 6) = "Direct" Then
      Sht.Range("F" & NR) = RNG.Areas(Grp).Cells(Itm)
    ElseIf Left(RNG.Areas(Grp).Cells(Itm), 8) = "Cellular" Then
      Sht.Range("G" & NR) = RNG.Areas(Grp).Cells(Itm)
    ElseIf Left(RNG.Areas(Grp).Cells(Itm), 3) = "Fax" Then
      Sht.Range("H" & NR) = RNG.Areas(Grp).Cells(Itm)
    Else
      Sht.Range("E" & NR) = RNG.Areas(Grp).Cells(Itm)
    End If
  Next Itm
  NR = NR + 1
Next Grp
Set RNG = Nothing
Set Sht = Nothing
Columns("C:K").AutoFit
Application.ScreenUpdating = True
End Sub


Then run the "ReorgDataV3" macro.
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,215,526
Messages
6,125,329
Members
449,218
Latest member
Excel Master

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