Macro or VBA to reformat a contact/phone list

[lzr]

I have a large sheet with data as follows. I would like to have a macro take this data and reformat into 1 row per record on a second sheet within the workbook, similar to the bottom example. One of the problems is the inconsistency of the existing data. The email address would be end of each record. The names are all formatted as Times New Roman 16.5 if it is possible to use that. Or, the cell following the email address is the next records name. If we could get the phone numbers copied into the appropriate column, even with the labels and numbers as they are, I think I could clean them up later. And, If the data is too messed up to be workable, my highest priority is getting a name, company name and email address extracted in the correct columns. The rest would be nice, but if it makes things exponentially harder, I can get that information in a later pass. As always, thanks for any help.

Excel 2012
	A
1	JOHN DOEA
2	Company CorporationA
3	134 Street
4	Edland,OH73101
5	Phone:(555) 228-1111
6	Mobile Number (555) 615-1234
7	john.doe@company1.com
8	JOHN DOEB
9	Company CorporationB
10	135 Street
11	Edland,OH73102
12	Phone:5552281112
13	john.doe@company2.com
14	JOHN DOEC
15	Company CorporationC
16	136 Street
17	PO Box 12
18	Edland,OH73103
19	Phone:(555) 228-1113
20	john.doe@company3.com
Sheet1

Excel 2012
	A	B	C	D	E	F	G
1	Name	Company	Address	CityStateZip	Phone	MobilePhone	Email
Sheet2

 

[Max1616]

Is your data always structured like this:
Name
Company
Address1
Address2
City,State,Zip
Phone
Email

Where each name is 7 cells from the previous and they always follow that order?

Thanks!

 

[lzr]

No, unfortunately it is not. Some have Fax numbers, second address lines, titles, etc. I think the new record consistently starts immediately after the email address. Other things that I think are true and consistent:

New record starts after email address
'Phone' is consistently the label for main number;
'Mobile Number' label is consistent;
city, St Zip are consistently formatted
The line immediately above the city, state zip is 99% of the time the address I'd want
Company name immediately follows individual name.

 

[MickG]

Although this code does not strictly align the details with the headings, it does place each Unique name in its own line, more that that would be quite difficult without being able to completely assess the data structure.

[COLOR="Navy"]Sub[/COLOR] MG16Dec40
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 1)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Ac = Ac + 1
    [COLOR="Navy"]If[/COLOR] UBound(ray, 2) < Ac [COLOR="Navy"]Then[/COLOR] ReDim Preserve ray(1 To Rng.Count, 1 To Ac)
    ray(c, Ac) = Dn.Value
    [COLOR="Navy"]If[/COLOR] InStr(Dn.Value, "@") > 0 [COLOR="Navy"]Then[/COLOR]
        Ac = 0: c = c + 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(ray, 2))
    .Value = ray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[lzr]

Mick, this gets me to a point I can finish the cleanup. Thank you very much for the help.

 

[MickG]

You're welcome