rearrange a column of businesses into meaningful rows & columns

[Gingertrees]

I'm trying to parse out the data in an Excel spreadsheet with over 10,000 lines of data. Unfortunately, it's not organized in a very helpful manner, with each line being a separate row, but every business taking up 4-6 rows, as below:

A's Business 1
400 Some Road
Cedar Falls, IA
Phone: (800) 111-2222
www.address1.com
info@address1.com
Aaron's Name place
110 L Street
Omaha, NE
Phone: (888) 222-3333
A1 Something
4 Flagstaff Rd
Rochester, NH
Phone: (800) 000-1234
www.a1something.com
brandon@a1somes.com
ABC Other Stuff
5000 Old Seward Hwy
Anchorage, AK
Phone: (800) 111-3455
www.abcothers.com
ABC Place, LLC
(etc)

If they all had 6 rows, that would be a pretty simple routine to write and perform... but the variable length, with some having 4 rows and some having 6... I just don't know what to do. Ideas?

 

[shg]

How would the code know when one company ends and the next starts -- i.e., what is consistently consistent?

 

[Gingertrees]

Well, every one has a city, st (zip was not included for some reason). So you have the 3rd line for each business has a comma, space, and 2 capitalized characters. Maybe we can work with that knowledge?

 

[sheetspread]

Is each line ending in .com followed by one that does not a break?

 

[Gingertrees]

Not exactly. e.g.:
A's Business 1
400 Some Road
Cedar Falls, IA
Phone: (800) 111-2222
www.address1.com
info@address1.com
There are 2 .com lines here. Also, some lines end in .net, and others have no email/URL at all.

I believe the answer is some little looping routine. I added a 2nd column, identifying the line as "state" if it met the , ## rule. Using that, something like [sucky pretend VBA ahead]

For each cell in range,
=if cell+1 column = "state"
cell = i

copy i-2 rows into name destination
copy i-1 row into address destination
copy i into city/state destination
copy i+1 row into phone destination

Next i

 

[sheetspread]

In your example there can be 1. no web or email (four lines) 2. either (five lines) 3. both (six). Is that the only varying factor?

 

[GTO]

Hi Ariel,

Regarding using the [city] comma [state abbreviation] as always being the third line of a record: are the states all U.S. states? I ask as it might be useful for a pattern to look for.

Mark

 

[Gingertrees]

sheetspread: that is correct. 4-6 lines, variant by existence or not of email and URL.
GTO: hi Mark! long time no see Yes, only US states, and the pattern is good for all 1800+ records.

 

[sheetspread]

Excel Workbook
	A	B	C
2	A's Business 1	1	TRUE
3	400 Some Road
4	Cedar Falls, IA
5	Phone: (800) 111-2222
6	www.address1.com
7	info@address1.com
8	Aaron's Name place
9	110 L Street
10	Omaha, NE
11	Phone: (888) 222-3333
12	A1 Something
13	4 Flagstaff Rd
14	Rochester, NH
15	Phone: (800) 000-1234
16	www.a1something.com
17	brandon@a1somes.com
18	ABC Other Stuff
19	5000 Old Seward Hwy
20	Anchorage, AK
21	Phone: (800) 111-3455
22	www.abcothers.com
23	ABC Place, LLC
Sheet3 (5)

Drag down:

Excel Workbook
	A	B	C
2	A's Business 1	1	TRUE
3	400 Some Road	2	TRUE
4	Cedar Falls, IA	3	TRUE
5	Phone: (800) 111-2222	4	TRUE
6	www.address1.com	5	TRUE
7	info@address1.com	6	TRUE
8	Aaron's Name place	1	TRUE
9	110 L Street	2	TRUE
10	Omaha, NE	3	TRUE
11	Phone: (888) 222-3333	4	TRUE
12	A1 Something	1	insert 2 rows
13	4 Flagstaff Rd	2	TRUE
14	Rochester, NH	3	TRUE
15	Phone: (800) 000-1234	4	TRUE
16	www.a1something.com	5	TRUE
17	brandon@a1somes.com	6	TRUE
18	ABC Other Stuff	1	TRUE
19	5000 Old Seward Hwy	2	TRUE
20	Anchorage, AK	3	TRUE
21	Phone: (800) 111-3455	4	TRUE
22	www.abcothers.com	5	TRUE
23	ABC Place, LLC	1	1
Sheet3 (7)

Highlight column B, Use F5 (Goto) Special-Formulas-Text to distinguish the "insert 2 rows" cells, then insert 2 rows.

Highlight column B, Use F5 (Goto) Special-Formulas-Number to distinguish the "1" cells, then insert 1 rows.

Excel Workbook
	A	B	C
2	A's Business 1	1	TRUE
3	400 Some Road	2	TRUE
4	Cedar Falls, IA	3	TRUE
5	Phone: (800) 111-2222	4	TRUE
6	www.address1.com	5	TRUE
7	info@address1.com	6	TRUE
8	Aaron's Name place	1	TRUE
9	110 L Street	2	TRUE
10	Omaha, NE	3	TRUE
11	Phone: (888) 222-3333	4	TRUE
12
13
14	A1 Something	1	insert 2 rows
15	4 Flagstaff Rd	2	TRUE
16	Rochester, NH	3	TRUE
17	Phone: (800) 000-1234	4	TRUE
18	www.a1something.com	5	TRUE
19	brandon@a1somes.com	6	TRUE
20	ABC Other Stuff	1	TRUE
21	5000 Old Seward Hwy	2	TRUE
22	Anchorage, AK	3	TRUE
23	Phone: (800) 111-3455	4	TRUE
24	www.abcothers.com	5	TRUE
25
26	ABC Place, LLC	1	1
Sheet3 (7)

Add headers to the right and an additional formula in D2

Excel Workbook
	A	B	C	D	E	F	G	H	I
1				Name	Address	City/State	Phone	Web	Email
2	A's Business 1	1	TRUE	A's Business 1
3	400 Some Road	2	TRUE
4	Cedar Falls, IA	3	TRUE
5	Phone: (800) 111-2222	4	TRUE
6	www.address1.com	5	TRUE
7	info@address1.com	6	TRUE
8	Aaron's Name place	1	TRUE
9	110 L Street	2	TRUE
10	Omaha, NE	3	TRUE
11	Phone: (888) 222-3333	4	TRUE
12
13
14	A1 Something	1	insert 2 rows
15	4 Flagstaff Rd	2	TRUE
16	Rochester, NH	3	TRUE
17	Phone: (800) 000-1234	4	TRUE
18	www.a1something.com	5	TRUE
19	brandon@a1somes.com	6	TRUE
20	ABC Other Stuff	1	TRUE
21	5000 Old Seward Hwy	2	TRUE
22	Anchorage, AK	3	TRUE
23	Phone: (800) 111-3455	4	TRUE
24	www.abcothers.com	5	TRUE
25
26	ABC Place, LLC	1	1
Sheet3 (7)

Copy across and down:

Excel Workbook
	A	B	C	D	E	F	G	H	I
1				Name	Address	City/State	Phone	Web	Email
2	A's Business 1	1	TRUE	A's Business 1	400 Some Road	Cedar Falls, IA	Phone: (800) 111-2222	www.address1.com	info@address1.com
3	400 Some Road	2	TRUE	Aaron's Name place	110 L Street	Omaha, NE	Phone: (888) 222-3333	0	0
4	Cedar Falls, IA	3	TRUE	A1 Something	4 Flagstaff Rd	Rochester, NH	Phone: (800) 000-1234	www.a1something.com	brandon@a1somes.com
5	Phone: (800) 111-2222	4	TRUE	ABC Other Stuff	5000 Old Seward Hwy	Anchorage, AK	Phone: (800) 111-3455	www.abcothers.com	0
6	www.address1.com	5	TRUE	ABC Place, LLC
7	info@address1.com	6	TRUE
8	Aaron's Name place	1	TRUE
9	110 L Street	2	TRUE
10	Omaha, NE	3	TRUE
11	Phone: (888) 222-3333	4	TRUE
12
13
14	A1 Something	1	insert 2 rows
15	4 Flagstaff Rd	2	TRUE
16	Rochester, NH	3	TRUE
17	Phone: (800) 000-1234	4	TRUE
18	www.a1something.com	5	TRUE
19	brandon@a1somes.com	6	TRUE
20	ABC Other Stuff	1	TRUE
21	5000 Old Seward Hwy	2	TRUE
22	Anchorage, AK	3	TRUE
23	Phone: (800) 111-3455	4	TRUE
24	www.abcothers.com	5	TRUE
25
26	ABC Place, LLC	1	1
Sheet3 (7)

 

[GTO]

Howdy All:

Here was my take. For an initial sheet like:

Excel Workbook
	A
1	HEADER
2	A's Business 1
3	400 Some Road
4	Cedar Falls, IA
5	Phone: (800) 111-2222
6	www.address1.com
7	info@address1.com
8	Aaron's Name place
9	110 L Street
10	Omaha, NE
11	Phone: (888) 222-3333
12	A1 Something
13	4 Flagstaff Rd
14	Rochester, NH
15	Phone: (800) 000-1234
16	www.a1something.com
17	brandon@a1somes.com
18	ABC Other Stuff
19	5000 Old Seward Hwy
20	Anchorage, AK
21	Phone: (800) 111-3455
22	www.abcothers.com
23	mark@somewhere.net
RawData

...and AFTER:

Excel Workbook
	D	E	F	G	H
1	NAME	ADDRESS	LOCATION	PHONE	EMAIL
2	A's Business 1	400 Some Road	Cedar Falls, IA	Phone: (800) 111-2222	www.address1.com
3					info@address1.com
4	Aaron's Name place	110 L Street	Omaha, NE	Phone: (888) 222-3333
5	A1 Something	4 Flagstaff Rd	Rochester, NH	Phone: (800) 000-1234	www.a1something.com
6					brandon@a1somes.com
7	ABC Other Stuff	5000 Old Seward Hwy	Anchorage, AK	Phone: (800) 111-3455	www.abcothers.com
8					mark@somewhere.net
RawData

Using another sheet for state codes like:

Excel Workbook
	A	B	C	D
1	State/Territory	Standard Abbreviation	Postal Abbreviation	Capital City
2	Alabama	Ala.	AL	Montgomery
3	Alaska	Alaska	AK	Juneau
4	American Samoa	n/a	AS	Pago Pago
5	Arizona	Ariz.	AZ	Phoenix
State Abbreviations

In a Standard Module:

Option Explicit
    
Sub ArielsParser()
Dim REX                     As Object '<--- RegExp
Dim rngData                 As Range
Dim Cell                    As Range
Dim aryOutput()             As String
Dim aryTranspose            As Variant
Dim lEndRow                 As Long
Dim lRow                    As Long
Dim n                       As Long
Dim nn                      As Long
Dim lLastEmail              As Long
Dim lFirstEmail             As Long
Dim lCurEmail               As Long
Dim strPattern              As String
Dim bolRuleOutLastRecord    As Boolean
    
    With shtPostalCodes
        For Each Cell In .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)).Cells
            strPattern = strPattern & Cell.Value & "|"
        Next
        strPattern = Left(strPattern, Len(strPattern) - 1)
        strPattern = "([A-z\ ]+\,\ +)(" & strPattern & ")"
    End With
    
    Set REX = CreateObject("VBScript.RegExp")
    With REX
        .Global = False
        .IgnoreCase = True
        .Pattern = strPattern
    End With
    ReDim aryOutput(1 To 5, 1 To 1)
    aryOutput(1, 1) = "NAME"
    aryOutput(2, 1) = "ADDRESS"
    aryOutput(3, 1) = "LOCATION"    '<---Look for
    aryOutput(4, 1) = "PHONE"
    aryOutput(5, 1) = "EMAIL"
    
    lEndRow = shtRawData.Cells(shtRawData.Rows.Count, 1).End(xlUp).Row
        
    With REX
        
        For n = 2 To lEndRow
            bolRuleOutLastRecord = False
            If .Test(shtRawData.Cells(n, 1).Value) Then
                ReDim Preserve aryOutput(1 To 5, 1 To UBound(aryOutput, 2) + 1)
                aryOutput(1, UBound(aryOutput, 2)) = shtRawData.Cells(n - 2, 1).Value
                aryOutput(2, UBound(aryOutput, 2)) = shtRawData.Cells(n - 1, 1).Value
                aryOutput(3, UBound(aryOutput, 2)) = shtRawData.Cells(n, 1).Value
                aryOutput(4, UBound(aryOutput, 2)) = shtRawData.Cells(n + 1, 1).Value
                
                For nn = n + 2 To lEndRow
                    If .Test(shtRawData.Cells(nn, 1).Value) Then
                        bolRuleOutLastRecord = True
                        lLastEmail = nn - 3
                        lFirstEmail = n + 2
                        
                        aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(lFirstEmail, 1).Value
                        
                        For lCurEmail = lFirstEmail + 1 To lLastEmail
                            ReDim Preserve aryOutput(1 To 5, 1 To UBound(aryOutput, 2) + 1)
                            aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(lCurEmail, 1).Value
                        Next
                        Exit For
                    End If
                Next
                
                If Not bolRuleOutLastRecord Then
                    aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(n + 2, 1).Value
                    For lCurEmail = n + 3 To lEndRow
                        ReDim Preserve aryOutput(1 To 5, 1 To UBound(aryOutput, 2) + 1)
                        aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(lCurEmail, 1).Value
                    Next
                End If
            End If
        Next
    End With
    
    For n = LBound(aryOutput, 1) To UBound(aryOutput, 1) - 1
        If aryOutput(5, n) = aryOutput(1, n + 1) Then aryOutput(5, n) = Empty
    Next
    
    '// IF in Excel2000, send aryOutput to another function to "manually" transpose.    //
    aryTranspose = Application.Transpose(aryOutput)
    
    shtRawData.Range("C1").Resize(UBound(aryTranspose, 1), UBound(aryTranspose, 2)).Value = aryTranspose
End Sub

Hope that helps,

Mark