parse address

[Damo71]

Hi<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
There is a database that imports address fields from an excel spreadsheet. I have no control over the database, so I need to fix some import problems in Excel first.<o></o>
<o></o>
The address field can only accept 30 characters including spaces and special characters. But a good few of the addresses in excel are longer. So I need to transport the “offcuts” to address line 2 (and in some rare cases, 3 as well)<o></o>
<o></o>
So let’s say I had the following address in cell A1: “Flat 4A, <?xml:namespace prefix = st1 ns = "urn:schemas-microsoft-comffice:smarttags" /><st1:Street w:st="on"><st1:address w:st="on">12 Polkington Crescent</st1:address></st1:Street>, Frisby-on-the-Wreake Melton Mowbray” (68 Characters). <o></o>
<o></o>
Is there a formula in B1 which will test the length of the text field in A1, if over 30 characters, look for the nearest space before character 31 (in this case the space before “Crescent”) And return the part of the address up to that space (“Flat 4A, 12 Polkington”)<o></o>
<o></o>
In cell C1, the same principle – search the remainder of the address (“Crescent, Frisby-on-the-Wreake Melton Mowbray” (45 characters), then test the length of the remaining text field, if over 30 characters, look for the nearest space before character 31 (in this case the space before “Melton”) And return the part of the address up to that space (“Crescent, Frisby-on-the-Wreake”)<o></o>
<o></o>
Finally in cell D1 the formula would return any remaining part of the address in A1 (but to a maximum length of 30 characters)<o></o>
<o></o>
I know theres a lot here, but I’m tearing my hair out and would really appreciate assistance.<o></o>
<o></o>
Thanks<o></o>
<o></o>
<o>PS - just to complicate matters further - commas and other common address separators can be treated as spaces by the above formulae (i.e. its acceptable to break the address up at a comma, space, full stop, semi colon etc - but not acceptable to break a word up)</o>

 

[jmthompson]

Well, I've figured out formulas based on the spaces, but it isn't pretty.

Formula for B1:

=IF(LEN(A1)>30,LEFT(A1,FIND("^^",SUBSTITUTE(LEFT(A1,30)," ","^^",30-LEN(SUBSTITUTE(LEFT(A1,30)," ",""))))),A1)

Formula for C1, this was trickier. The formula I want to use isn't allowable because it exceeds the nesting limit. I got round this by using a helper column.

Formula for C1

=IF(LEN(A1)>30,I1,"")

Formula for I1 (helper column)

=MID(A1,LEN(B1)+1,FIND("^^",SUBSTITUTE(LEFT(RIGHT(A1,LEN(A1)-LEN(B1)),31)," ","^^",31-LEN(SUBSTITUTE(LEFT(RIGHT(A1,LEN(A1)-LEN(B1)),31)," ",""))))-1)

Formula for D1:

=IF(LEN(A1)>30,LEFT(RIGHT(A1,LEN(A1)-(LEN(B1)+LEN(C1))-1),30),"")

 

[Damo71]

hi

thanks for your reply and apologies for the delay.

I'm getting the value error on every cell in column I. So whenever A1 exceeds 30 characters, B1, C1 and D1 return the value error also.

Any ideas?

Thanks

 

[Rick Rothstein]

Can you make use of a macro? If so, run the following macro and select the range whose addresses you want to split apart when asked (the range can contain blank cells and/or the range can be non-contiguous)...

Sub SplitTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, TextMax As String, SplitText As String, SplitApart() As String
  Dim Space As Long, Source As Range, CellWithText As Range
  Const MaxChars As Long = 30
  On Error GoTo NoCellsSelected
  Set Source = Application.InputBox("Select cells to process:", Type:=8)
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      If Right(TextMax, 1) = " " Then
        SplitText = SplitText & RTrim(TextMax) & vbLf
        Text = Mid(Text, MaxChars + 2)
      Else
        Space = InStrRev(TextMax, " ")
        If Space = 0 Then
          SplitText = SplitText & Left(Text, MaxChars) & vbLf
          Text = Mid(Text, MaxChars + 1)
        Else
          SplitText = SplitText & Left(TextMax, Space - 1) & vbLf
          Text = Mid(Text, Space + 1)
        End If
      End If
    Loop
    SplitApart = Split(SplitText & Text, vbLf)
    If UBound(SplitApart) >= 0 Then CellWithText.Offset(, 1).Resize(, UBound(SplitApart) + 1) = Split(SplitText & Text, vbLf)
  Next
NoCellsSelected:
End Sub

 

[GTO]

Well, here was my shot. Similar to Rick's (leastwise with the exxaample sub calling), just select the cells with the addresses (in a junk copy of your wb). I tested just against:

Excel Workbook
	A
1	My Header
2	Flat 4A, 12 Polkington Crescent, Frisby-on-the-Wreake Melton Mowbray
3	Flat 12314A1321, 12 Polkington Crescent, Frisby-on-the-Wreake Melton Mowbray, Some County
4	AReallyReallySuperDuperLongWordThatWeCannotSplit
5	Suite 1, Small Town, Someplace
Sheet1

Option Explicit
    
Sub exa()
Dim Cell    As Range
Dim vntVal  As Variant
    
    For Each Cell In Selection
        vntVal = Cell.Value
        If LimitStrLen(vntVal) Then
            If IsArray(vntVal) Then
                Cell.Offset(, 1).Resize(, UBound(vntVal)).Value = vntVal
            Else
                Cell.Offset(, 1).Value = vntVal
            End If
        End If
    Next
End Sub
    
Function LimitStrLen(Text As Variant) As Boolean
Dim REX             As Object '<--- RegExp
Dim rexMatch        As Object '<--- Match
Dim strTmp          As String
Dim strTmpRev       As String
Dim aryTmp()        As Variant
Dim str_aryTemp     As Variant
    
    Set REX = CreateObject("VBScript.RegExp")
    REX.Global = False
    REX.IgnoreCase = True
    REX.Pattern = "[, .;]"
    
    '// For any cells under 31 LEN, just pass  Text back    //
    If Len(Text) > 30 Then
        
        '// Initially size, but we'll bump the base.        //
        ReDim str_aryTemp(0 To 0)
        
        '// Split the first 30 chars from the remainder     //
        aryTmp = Array(Left(Text, 30), Mid(Text, 31))
        
        Do
            '// Two temp strings, one reversed, of the first 30 chars currently being   //
            '// looked at                                                               //
            strTmp = aryTmp(0)
            strTmpRev = StrReverse(aryTmp(0))
            
            '// See if we find one of our acceptable break-point chars                  //
            If REX.Test(strTmpRev) Then
                Set rexMatch = REX.Execute(strTmpRev)(0)
                '// Assuming we found a breakpoint in the reversed string, trim reg tmp //
                '// string and assign it to the first element in the array              //
                strTmp = Left(strTmp, Len(strTmp) - rexMatch.FirstIndex)
                aryTmp(0) = strTmp
                '// Save  the stuff we hacked off back into the second element          //
                aryTmp(1) = StrReverse(Left(strTmpRev, rexMatch.FirstIndex)) & aryTmp(1)
                
                '// Store our bits of text in our dynamically sixing array              //
                ReDim Preserve str_aryTemp(1 To UBound(str_aryTemp) + 1)
                str_aryTemp(UBound(str_aryTemp)) = aryTmp(0)
                
                '// Plunk what's left back into Text to feed the next loop              //
                Text = aryTmp(1)
                aryTmp = Array(Left(Text, 30), Mid(Text, 31))
                
            Else
                LimitStrLen = False
                Exit Function
            End If
        Loop While Len(Text) > 30
        
        '// Not tested, but I think should catch?                                       //
        If Len(Text) > 0 Then
            ReDim Preserve str_aryTemp(1 To UBound(str_aryTemp) + 1)
            str_aryTemp(UBound(str_aryTemp)) = Text
        End If
        
        '// Pass Text back as an array                                                  //
        Text = str_aryTemp
        LimitStrLen = True
    Else
        LimitStrLen = True
    End If
End Function