Darren Bartrup
Well-known Member
- Joined
- Mar 13, 2006
- Messages
- 1,297
- Office Version
- 365
- Platform
- Windows
Not a question, I just wanted to share this code.
If you have an address in a single cell, this function will split it into its component parts when entered as an array formula over however many cells you wish.
The second parameter will align the (UK) postcode to the right if set to true (defaults to false), the third parameter puts any overflow components to the left if set to false (defaults to true) and the fourth parameter is the address delimiter (default is a comma).
Any comments and improvements gladly accepted!
Darren.
If you have an address in a single cell, this function will split it into its component parts when entered as an array formula over however many cells you wish.
The second parameter will align the (UK) postcode to the right if set to true (defaults to false), the third parameter puts any overflow components to the left if set to false (defaults to true) and the fourth parameter is the address delimiter (default is a comma).
Any comments and improvements gladly accepted!
Code:
'//Parameters: Target - single cell containing source address.
'// AlignPostCode - Places the postcode in the rightmost column of the selected range.
'// False (default) = don't align postcode.
'// AlignOverFlow - Place overflow to left or right. Default is right.
'// Delimiter - Separates between address. Default is a comma.
Public Function SplitAddress(Target As Range, Optional AlignPostCode As Boolean = False, _
Optional AlignOverFlowLeft As Boolean = True, Optional Delimiter As String = ",") As Variant
Dim lngRangeSize As Long, lngTargetSize As Long
Dim strTargetValue As String
Dim aTarget As Variant
Dim aFinalArray As Variant
Dim objRGX As Object
Dim UKPostCode As String
Dim colMatches As Variant
Dim i As Long, j As Long, k As Long
UKPostCode = "(?:(?:A[BL]|B[ABDHLNRST]?|C[ABFHMORTVW]|D[ADEGHLNTY]|E[CHNX]?|F[KY]|G[LUY]?|" _
& "H[ADGPRSUX]|I[GMPV]|JE|K[ATWY]|L[ADELNSU]?|M[EKL]?|N[EGNPRW]?|O[LX]|P[AEHLOR]|R[GHM]|S[AEGKLMNOPRSTWY]?|" _
& "T[ADFNQRSW]|UB|W[ACDFNRSV]?|YO|ZE)\d(?:\d|[A-Z])? \d[A-Z]{2})"
lngRangeSize = Application.Caller.Count
strTargetValue = Replace(Replace(Trim(Replace(Replace(Target.Value, Chr$(13), _
""), Chr$(10), Delimiter)), Delimiter & " ", Delimiter), Delimiter & Delimiter, Delimiter)
ReDim aFinalArray(1 To lngRangeSize)
If AlignPostCode Then
Set objRGX = CreateObject("VBScript.RegExp")
With objRGX
.Pattern = UKPostCode
.Global = True
Set colMatches = .Execute(strTargetValue)
End With
If colMatches.Count Then
'//Move the postcode to the end of the string.
strTargetValue = Replace(Replace(strTargetValue, colMatches(0), "") & _
Delimiter & colMatches(0), Delimiter & Delimiter, Delimiter)
End If
End If
aTarget = Split(strTargetValue, Delimiter)
lngTargetSize = UBound(aTarget) + 1
If AlignPostCode Then
If colMatches.Count Then
aFinalArray(lngRangeSize) = aTarget(UBound(aTarget))
lngRangeSize = lngRangeSize - 1
lngTargetSize = lngTargetSize - 1
End If
End If
If lngTargetSize - lngRangeSize <= 0 Then
'//The final array size is larger than the passed array.
'//Everything will fit with room to spare.
j = 0
For i = 1 To lngRangeSize
If j < lngTargetSize Then
aFinalArray(i) = aTarget(j)
Else
aFinalArray(i) = ""
End If
j = j + 1
Next i
Else
'//The final array size is smaller than the passed array.
If Not AlignOverFlowLeft Then
'//The excess passed elements need to be placed to the left.
j = lngRangeSize
For i = lngTargetSize - 1 To 0 Step -1
If j > 0 Then
aFinalArray(j) = aTarget(i)
j = j - 1
Else
aFinalArray(1) = aTarget(i) & Delimiter & " " & aFinalArray(1)
End If
Next i
Else
'//The excess passed elements need to be placed to the right.
j = 1
For i = 0 To lngTargetSize - 1
If j <= lngRangeSize Then
aFinalArray(j) = aTarget(i)
j = j + 1
Else
aFinalArray(j - 1) = aFinalArray(j - 1) & Delimiter & aTarget(i)
End If
Next i
End If
End If
SplitAddress = aFinalArray
End FunctionDarren.
