Extract postal code from address using isNumeric - excel

Question

I want to extract postal code from address. I have tried isNumeric method below to extract 6 numeric from the address. Some of the address got 5 digit and some got 6 digit postal code.
But there is some error where sometimes 11900 only show 1900, 08000 shows 8000, and 4 digit number also show.
Range("A2").Select
i = 2
Do While ActiveCell <> ""
Address = UCase(Trim(Range("C" & CStr(i))) + " " + Trim(Range("D" & CStr(i))) + " " + Trim(Range("E" & CStr(i))) + " " + Trim(Range("F" & CStr(i))))
For p = 1 To Len(Address)
If IsNumeric(Mid(Address , p, 6)) Then
Range("O" & CStr(i)) = Mid(Address, p, 6)
End If
Next p
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop
excel output
Address Postal Code
Wisma Pansar, 23-27 Jln Bengkel P.O. Box 319, 96007 Sibu Sarawak 96007
Wisma Lim , Lot 50A, Sec. 92A, 3.1/2 Sg Besi, 57100 Kuala Lumpur 57100
No. 265A, Jalan Sungai Petani 08300 Gurun Kedah Darul Aman 8300
No. 39, Jalan Nipah, Taman Lip Sin 11900 Sungai Nibong Pulau Pinang 1900
4-G, Lebuh Sungai Pinang 1 Sri Pinang 11600 Jelutong Pulau Pinang 11600
539/2, Gypsum Metropolitan Tower, Rajthevee Bangkok 10400, Thailand 0400,
LOTS 1869 &1938, 18th MILE KAJANG, SEMENYIH ROAD SELANGOR D.E. 1938, *no postal code in address
36a, Joo Chiat Place, Singapore 427760 0

Answer 1

I mean something like this:
Sub test()
Dim c As Range, p As Long, v, addr, i As Long, hit As Boolean
Set c = Range("A2") 'no need to select the cell
Do While c <> ""
addr = c.Value 'using your examples
hit = False
For p = 1 To Len(addr)
'will accept 5 or 6 digits - prefer 6
' so count down...
For i = 6 To 5 Step -1
v = Mid(addr, p, i)
If v Like String(i, "#") Then
c.Offset(0, 1).NumberFormat = "#" 'in case of leading zero
c.Offset(0, 1).Value = v
hit = True
Exit For
End If
Next i
If hit Then Exit For
Next p
Set c = c.Offset(1, 0)
Loop
End Sub
A regular expression approach would probably be much nicer.

Answer 2

To complement #TimWilliams his answer, hereby a solution making use of Array and Regular Expressions (with late binding). So let's immagine the following setup:
Now run the following code:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.regexp")
'Set up regular expression
RegEx.Pattern = "\d{5,6}"
RegEx.Global = True
'Go through your data and execute RegEx
With Sheet1 'Change according to your sheets CodeName
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:A" & lr).Value
.Range("B2:B" & lr).NumberFormat = "#"
For x = LBound(arr) To UBound(arr)
Set Matches = RegEx.Execute(arr(x, 1))
For Each Match In Matches
.Cells(x + 1, 2) = Match.Value
Next Match
Next x
End With
End Sub
Assuming the possibility of multiple matches within a string, the last match will be used.
If you are sure there can only be one match (or none), then you could also use:
If Matches.Count = 1 Then .Cells(x + 1, 2) = Matches.Item(0)
Instead of:
For Each Match In Matches
.Cells(x + 1, 2) = Match.Value
Next Match