VBA 替换字符串 EXCEL 2019

Question

I cannot extract the postal/zip code of a given address cell that comes like this:

"108, avenue du Grand Sud 37 170 CHAMBRAY les TOURS".

I have used:

=RECHERCHE(9^9;--("0"&STXT(A2;MIN(CHERCHE({0.1.2.3.4.5.6.7.8.9};A2&"0 123456789"));LIGNE($1:$100))))

Which sometimes works, sometimes not depending on the street number starting the address (here "108,").

The problem is the space of the pattern "37 170". I would like to remove the blank space in the pattern. Is there a regex way to search this pattern "## ###", and then to remove this poisonous blank space?

Thank you for your tricks.

I have tried this piece of code:

Function toto(r, Optional u = 0)
Application.Volatile
Dim i%, j%, adr$, cp$, loca$, x
  x = Split(r)
  For i = 0 To UBound(x)
    If x(i) Like "#####" Then Exit For
  Next
  If i > UBound(x) Then
    adr = r.Value 'facultatif
  Else
    cp = x(i)
    For j = 0 To i - 1: adr = adr & x(j) & " ": Next
    adr = Left$(adr, Len(adr) + (Len(adr) > 1))
    For j = i + 1 To UBound(x): loca = loca & x(j) & " ": Next
    loca = Left$(loca, Len(loca) + (Len(loca) > 1))
  End If
  x = Array(adr, cp, loca)
  If 0 < u And u < 4 Then toto = x(u - 1) Else toto = x
End Function

The above code works fine for splitting addresses including street number, zip code, and city name. But it does not work when the zip code is ## ### = 2 digit integer - space - 3 digit integer.

Edit: 01 June 2021

Since it seems my question is not clear enough, let's rephrase:

Given an Excel worksheet containing in each cell of column A, from saying A1 down to A10000, complete addresses like this one:

"2 rue Rene cassin Centre Commercial Châlon 2 Sud 71 100 CHALON SUR SAONE" or this one: "15, Rue Emile Schwoerer 68 000 COLMAR"

Where "71 100" and "68 000" are a zip code in incorrect format because of the extra space between the 2 first digits and 3 last digits.

I need to split the Ai cell content in order to obtain:

• in cell Bi: the text (street, etc.) placed left before the 2 first digits of the "wrong" zip code,
• in cell Ci: the zip code with its correct format ("71100" and not "71 100"),
• in cell Di: the text (city name) after the zip code.

It's a kind of left and right extraction around the zip code.

The above code that I have posted does not work.

In order to obtain the correct zip code format, I have tried the regex following function:

Function FindReplaceRegex(rng As Range, reg_exp As String, replace As String)
    Set myRegExp = New RegExp
    myRegExp.IgnoreCase = False
    myRegExp.Global = True
    myRegExp.Pattern = reg_exp
    
    FindReplaceRegex = myRegExp.replace(rng.Value, replace)
End Function

But I am unable to determine the correct regular expression pattern to get rid of the space in the zip code. PEH gave me the following pattern:

(.*)([0-9]{2}?[0-9]{3})(.*)

When using the function, I have tried to define the replacement pattern by:

(.*)([0-9]{2}[0-9]{3})(.*)

But it would not work. Hope this will clarify my question.

Any idea is welcome. Thanks

Answer 1

If these input strings always have the same pattern, try:

=CONCAT(FILTERXML("<t><s>"&SUBSTITUTE(A1," ","</s><s>")&"</s></t>","//s[.*0=0]"))

Depending on your needs/edge-cases, you could add more xpath expressions.

Answer 2

If this is VBA, I have a fix for you (please forgive the crappy naming convention, I'm scribbling this down in work while waiting for SQL to refresh):

Sub test1()

a0 = Cells(1, 1)  'Get the text, in this case "108, avenue du Grand Sud 37 170 CHAMBRAY les TOURS"
aa = Replace(a0, ",", " ")  'Make all delimiters of same type, so removing commas, you may need to add more replace work here?
ab = Application.Trim(aa)  'Reduce all whitespace to single entries, i.e. " " rather than "  "
ac = Split(ab, " ", -1)  'Now split by that single whitespace entry

Dim txt()

i2 = 0
lastIsNumeric = False
For i1 = 0 To UBound(ac) - 1  'Step through each entry in our "split" list

    If IsNumeric(ac(i1)) = True And IsNumeric(ac(i1 + 1)) = True Then     
        'Two numbers back to back, join
        ReDim Preserve txt(i2)
        txt(i2) = ac(i1) + ac(i1 + 1)
        i2 = i2 + 1
        i1 = i1 + 1
    Else
        'Not two numbers back to back, don't join
        ReDim Preserve txt(i2)
        txt(i2) = ac(i1)
        i2 = i2 + 1
    
    End If

Next i1


If IsNumeric(ac(UBound(ac))) = False Then
    'Need to add last entry to txt()
    ReDim Preserve txt(UBound(txt) + 1)
    txt(UBound(txt)) = ac(UBound(ac))
End If

End Sub

edit 2021-06-01: The above will generate a list (txt) of all the entries within your address. You can then reassemble if you wish, or extract out the postcode only.

If you want it as a function, then it would be:

Public Function getPostcode(a0)

aa = Replace(a0, ",", " ")
ab = Application.Trim(aa)
ac = Split(ab, " ", -1)

Dim txt()

i2 = 0
lastIsNumeric = False
For i1 = 0 To UBound(ac) - 1
    If IsNumeric(ac(i1)) = True And IsNumeric(ac(i1 + 1)) = True Then
        'Two numbers back to back, join
        ReDim Preserve txt(i2)
        txt(i2) = ac(i1) + ac(i1 + 1)
        i2 = i2 + 1
        i1 = i1 + 1
    Else
        'Not two numbers back to back, don't join
        ReDim Preserve txt(i2)
        txt(i2) = ac(i1)
        i2 = i2 + 1
    
    End If

Next i1


If IsNumeric(ac(UBound(ac))) = False Then
    'Need to add last entry to txt()
    ReDim Preserve txt(UBound(txt) + 1)
    txt(UBound(txt)) = ac(UBound(ac))
End If

'Re-assemble string for return
rtnTxt = ""
For i1 = 0 To UBound(txt)
    rtnTxt = rtnTxt & " " & txt(i1)
Next i1

getPostcode = rtnTxt

End Function