rearrange a column of businesses into meaningful rows & columns

Gingertrees

Gingertrees

Well-known Member
Joined
Sep 21, 2009
Messages
697
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?
 
Sort by date Sort by votes
ACK!

Ariel, please notice that I changed the sheet's codenames and used those.

Mark
 
Upvote 0

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Well, I used sheetspread's code for my first bunch (though that's just the beginning) - that was pretty good, though I got tripped up by some non-standard URLs (http://another.biz, buckets.com/yellow, etc) and in one case, an email that started with a number. I was investigating fixes for that... but Mark's code looks more automated, so I'll try that tomorrow. I think I could create a custom function to identify the URLs vs. emails...
working that angle in the thread here:
http://www.mrexcel.com/forum/showthread.php?p=3044835&posted=1#post3044835
 
Upvote 0
Gingertrees said:
... I think I could create a custom function to identify the URLs vs. emails...
Click to expand...

Sorry, I am afraid I blew right by that bit. Here's a stab.

Rich (BB code): 
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 6, 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"
    aryOutput(6, 1) = "WEB"
    
    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 6, 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
'// Pattern based on: http://regexlib.com/UserPatterns.aspx?authorId=a0877382-1449-42c3-85eb-385493eb2a58   //
'//               By: Remi Sabourin                                                                         //
                        .Pattern = "^(http://)?([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6}$"
                        
                        If .Test(shtRawData.Cells(lFirstEmail, 1).Value) Then
                            aryOutput(6, UBound(aryOutput, 2)) = shtRawData.Cells(lFirstEmail, 1).Value
                        Else
                            aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(lFirstEmail, 1).Value
                        End If
                        
                        For lCurEmail = lFirstEmail + 1 To lLastEmail
                            
                            If .Test(shtRawData.Cells(lCurEmail, 1).Value) Then
                                If Not aryOutput(6, UBound(aryOutput, 2)) = Empty Then
                                    ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                                End If
                                aryOutput(6, UBound(aryOutput, 2)) = shtRawData.Cells(lCurEmail, 1).Value
                            Else
                                If Not aryOutput(5, UBound(aryOutput, 2)) = Empty Then
                                    ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                                End If
                                aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(lCurEmail, 1).Value
                            End If
                        Next
                        .Pattern = strPattern
                        Exit For
                    End If
                Next
                
                If Not bolRuleOutLastRecord Then
                    
                    .Pattern = "^(http://)?([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6}$"
                    
                    If .Test(shtRawData.Cells(n + 2, 1).Value) Then
                        aryOutput(6, UBound(aryOutput, 2)) = shtRawData.Cells(n + 2, 1).Value
                    Else
                        aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(n + 2, 1).Value
                    End If
                        
                    For lCurEmail = n + 3 To lEndRow
                        If .Test(shtRawData.Cells(lCurEmail, 1).Value) Then
                            If Not aryOutput(6, UBound(aryOutput, 2)) = Empty Then
                                ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                            End If
                            aryOutput(6, UBound(aryOutput, 2)) = shtRawData.Cells(lCurEmail, 1).Value
                        Else
                            If Not aryOutput(5, UBound(aryOutput, 2)) = Empty Then
                                ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                            End If
                            aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(lCurEmail, 1).Value
                        End If
                    Next
                    Exit For
                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)
    
    With shtRawData.Range("C1").Resize(UBound(aryTranspose, 1), UBound(aryTranspose, 2))
        .Value = aryTranspose
        With .Rows(1)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
        .EntireColumn.AutoFit
    End With
End Sub

Mark
 
Upvote 0
It did not work when I had a header over the column, but sort of did when I removed it and put the first business in A1, then ran the code.

Only problem here is for the businesses missing an email or URL. In those cases, it throw off the column order, like:
Abe's Ales...../123 Any St............../Omaha, NE/Phone: 323-233-2222/B's Goods/455 Main Hwy./
Bucktown, FL/Phone: 444-234-3333/www.a.net/atrer@email.net......../Cici Business/1 A St

(etc)
??
 
Upvote 0
Sorry Ariel, I appear to be having some "issues" with getting my head around this. :banghead:

This is turning a bit ugly code-wise, but appears to work against:<TABLE style="WIDTH: 137pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=183 border=0><COLGROUP><COL style="WIDTH: 137pt; mso-width-source: userset; mso-width-alt: 6692" width=183><TBODY><TR style="HEIGHT: 15.75pt" height=21><TD class=xl64 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; WIDTH: 137pt; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15.75pt; BACKGROUND-COLOR: transparent" width=183 height=21>HEADER</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>A's Business 1</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>400 Some Road</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Cedar Falls, IA</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phone: (800) 111-2222</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>www.address1.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>info@address1.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Aaron's Name place</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>110 L Street</TD></TR><TR style="HEIGHT: 15.75pt" height=21><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15.75pt; BACKGROUND-COLOR: transparent" height=21>Omaha, NE</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phone: (888) 222-3333</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>A1 Something</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>4 Flagstaff Rd</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Rochester, NH</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phone: (800) 000-1234</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>www.a1something.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>brandon@a1somes.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>ABC Other Stuff</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>5000 Old Seward Hwy</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Anchorage, AK</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phone: (800) 111-3455</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>www.abcothers.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>mark@somewhere.net</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>gto@nowhere.hotmail</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>http://arielspage.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Loper's Performance Center</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>900 E. Indian School Rd.</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phoenix, AZ</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phone:(800)555-5555</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Hal's Radiator Repair</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>5100 W. Glendale Ave</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Glendale, AZ</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phone: (555) 111-0033</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Lucky's Supermarket</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>3502 W. Glendale</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phoenix, AZ</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Phone: (123) 321-0037</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>Lucky.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>www.lucky.com</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>http://lucky.com/home</TD></TR><TR style="HEIGHT: 15pt" height=20><TD class=xl65 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 15pt; BACKGROUND-COLOR: transparent" height=20>mrlucky@freemail.com

Which returns:
Excel Workbook
CDEFGH
1NAMEADDRESSLOCATIONPHONEEMAILWEB
2A's Business 1400 Some RoadCedar Falls, IAPhone: (800) 111-2222info@address1.comwww.address1.com
3Aaron's Name place110 L StreetOmaha, NEPhone: (888) 222-3333
4A1 Something4 Flagstaff RdRochester, NHPhone: (800) 000-1234brandon@a1somes.comwww.a1something.com
5ABC Other Stuff5000 Old Seward HwyAnchorage, AKPhone: (800) 111-3455mark@somewhere.netwww.abcothers.com
6gto@nowhere.hotmailhttp://arielspage.com
7Loper's Performance Center900 E. Indian School Rd.Phoenix, AZPhone:(800)555-5555
8Hal's Radiator Repair5100 W. Glendale AveGlendale, AZPhone: (555) 111-0033
9Lucky's Supermarket3502 W. GlendalePhoenix, AZPhone: (123) 321-0037http://lucky.com/homeLucky.com
10mrlucky@freemail.comwww.lucky.com
RawData
Excel 2010

Still in a Standard Module...

Rich (BB code): 
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 lLastVal                As Long
Dim lLastCompanyName        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 6, 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"
    aryOutput(6, 1) = "WEB"
    
    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 6, 1 To UBound(aryOutput, 2) + 1)
                lLastCompanyName = UBound(aryOutput, 2)
                
                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
                
                If Not .Test(shtRawData.Cells(n + 4, 1).Value) Then
                
                    For nn = n + 2 To lEndRow
                        If .Test(shtRawData.Cells(nn, 1).Value) Then
                            bolRuleOutLastRecord = True
                            lLastEmail = nn - 3
                            lFirstEmail = n + 2
                            
    '// Pattern based on: http://regexlib.com/UserPatterns.aspx?authorId=a0877382-1449-42c3-85eb-385493eb2a58   //
    '//               By: Remi Sabourin                                                                         //
                            .Pattern = "^(http://)?([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6}$"
                            
                            If .Test(shtRawData.Cells(lFirstEmail, 1).Value) Then
                                aryOutput(6, UBound(aryOutput, 2)) = shtRawData.Cells(lFirstEmail, 1).Value
                            Else
                                aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(lFirstEmail, 1).Value
                            End If
                            
                            For lCurEmail = lFirstEmail + 1 To lLastEmail
                                
                                If .Test(shtRawData.Cells(lCurEmail, 1).Value) Then
                                    If Not aryOutput(6, UBound(aryOutput, 2)) = Empty Then
                                        ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                                    End If
                                    lLastVal = UBound(aryOutput, 2)
                                    Do
                                        lLastVal = lLastVal - 1
                                    Loop While aryOutput(6, lLastVal) = Empty And lLastVal >= lLastCompanyName
                                    aryOutput(6, lLastVal + 1) = shtRawData.Cells(lCurEmail, 1).Value
                                Else
                                    If Not aryOutput(5, UBound(aryOutput, 2)) = Empty Then
                                        ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                                    End If
                                    lLastVal = UBound(aryOutput, 2)
                                    Do
                                        lLastVal = lLastVal - 1
                                    Loop While aryOutput(5, lLastVal) = Empty And lLastVal >= lLastCompanyName
                                    aryOutput(5, lLastVal + 1) = shtRawData.Cells(lCurEmail, 1).Value
                                End If
                            Next
                            .Pattern = strPattern
                            Exit For
                        End If
                    Next
                    
                    If Not bolRuleOutLastRecord Then
                        
                        .Pattern = "^(http://)?([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6}$"
                        
                        If .Test(shtRawData.Cells(n + 2, 1).Value) Then
                            aryOutput(6, UBound(aryOutput, 2)) = shtRawData.Cells(n + 2, 1).Value
                        Else
                            aryOutput(5, UBound(aryOutput, 2)) = shtRawData.Cells(n + 2, 1).Value
                        End If
                            
                        For lCurEmail = n + 3 To lEndRow
                            If .Test(shtRawData.Cells(lCurEmail, 1).Value) Then
                                If Not aryOutput(6, UBound(aryOutput, 2)) = Empty Then
                                    ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                                End If
                                lLastVal = UBound(aryOutput, 2)
                                Do
                                    lLastVal = lLastVal - 1
                                Loop While aryOutput(6, lLastVal) = Empty And lLastVal >= lLastCompanyName
                                aryOutput(6, lLastVal + 1) = shtRawData.Cells(lCurEmail, 1).Value
                            Else
                                If Not aryOutput(5, UBound(aryOutput, 2)) = Empty Then
                                    ReDim Preserve aryOutput(1 To 6, 1 To UBound(aryOutput, 2) + 1)
                                End If
                                lLastVal = UBound(aryOutput, 2)
                                Do
                                    lLastVal = lLastVal - 1
                                Loop While aryOutput(5, lLastVal) = Empty And lLastVal >= lLastCompanyName
                                aryOutput(5, lLastVal + 1) = shtRawData.Cells(lCurEmail, 1).Value
                            End If
                        Next
                        Exit For
                    End If
                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)
    
    With shtRawData.Range("C1").Resize(UBound(aryTranspose, 1), UBound(aryTranspose, 2))
        .Value = aryTranspose
        With .Rows(1)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
        .EntireColumn.AutoFit
    End With
End Sub

If that works and you want any part explained, I'll comment it up.

Have a great weekend:beerchug:,

Mark
 
Upvote 0
Ahh for Pete's sakes! I forgot to mention, that I did see that the Pattern does not allow for catching web pages with .com/otherstuff at the end. Also, ignore the frowny faces; just my crappy typing and missing the space bar.
 
Upvote 0
Sorry for the late reply - extremely busy right now, sidelined with even more fun. ^_^

Hmm, I'm still trying to figure out that web bit. If I could make a function work, I might be able to call a function into your code above to detect URLs. I was trying to go that route initially, while using the more complex procedure suggested to me first. If you want, see the function by tigeravatar after the jump, as well as my comment on its flaw:
http://www.mrexcel.com/forum/showthread.php?t=614247

As always, any help is appreciated. Thanks!!! :-)
 
Upvote 0
I'm at it again. I've modified sheetspread's procedure as follows, now I just need to get my data into rows. See this:
Organizing addresses again, I have a long list with up to 7 lines per entry. I have labeled this thusly:
SMITH'S PARTS............1
300 MAIN ST, ABE NC....2
PHONE: 300-222-2222...3
FAX............................4
WEB: WWW.____.NET....5
CONTACT: JON SMITH....6
GET DIRECTIONS...........7

But since not all businesses have Fax info, or a website, sometime the numbers go like this:
...1
...2
...3
...6
...7
...1
...2
...3
...4
...6
...7
(etc)
This is in one big column of numbers (column B). There's always a 1,2,3, 6,and 7. The middle ones get tricky.

I want to change from that column to rows with 7 columns like:
Name.......Addr........Phone...Fax...Web...Contact...Directions

Ideas?
 
Upvote 0
Would a macro that inserts blank rows in between number skips help?

example:

1x
2x
3x
4x
7x
1x
2x
3x
4x
5x
7x


becomes

1 x
2 x
3 x
4 x
5 x
6 0
7 0
1 x
2 x
3 x
4 x
5 x
6 0
7 x
 
Upvote 0
You must log in or register to reply here.

Similar threads

Gingertrees
  • Question Question
Turn 1 huge column into 7 with rows separated by certain values
Replies
6
Views
857
circledchicken
C

Forum statistics

Threads
1,223,239
Messages
6,170,947
Members
452,368
Latest member
jayp2104

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