adam087
Well-known Member
- Joined
- Jun 7, 2010
- Messages
- 1,356
Hi All
I put together this UDF for some of my coworkers to turn a list of residents/guests/passengers in to useful salutations in order that communication might be better personalised. I'm posting it here because a) it saves us LOADS of time and therefore might help someone else; and b) the coding is my usual amateur stuff and would welcome any feedback on its improvement.
Here's what it does...
Excel 2010
<tbody>
</tbody>
<tbody>
</tbody>
-----------------------------------------------
And here's the code
Thanks for any feedback!
/AJ
I put together this UDF for some of my coworkers to turn a list of residents/guests/passengers in to useful salutations in order that communication might be better personalised. I'm posting it here because a) it saves us LOADS of time and therefore might help someone else; and b) the coding is my usual amateur stuff and would welcome any feedback on its improvement.
Here's what it does...
Excel 2010
| A | B | C | D | E | F | |
|---|---|---|---|---|---|---|
| 1 | Room No | Title | Surname | Room No | Salutation | |
| 2 | 1 | Mr | James | 1 | Mr & Mrs James | |
| 3 | 1 | Mrs | James | 2 | Lord Smith & Lady Jones | |
| 4 | 2 | Lord | Smith | 3 | Mr Horton | |
| 5 | 2 | Lady | Jones | 4 | Mrs Sutcliffe | |
| 6 | 3 | Mr | Horton | 5 | Mr & Mrs & Miss Brady | |
| 7 | 4 | Mrs | Sutcliffe | 6 | Dr & Mrs Way | |
| 8 | 5 | Mr | Brady | |||
| 9 | 5 | Mrs | Brady | |||
| 10 | 5 | Miss | Brady | |||
| 11 | 6 | Dr | Way | |||
| 12 | 6 | Mrs | Way |
<tbody>
</tbody>
Worksheet Formulas
<tbody> </tbody> |
<tbody>
</tbody>
-----------------------------------------------
And here's the code
Code:
Option Explicit
Public Function SALULOOKUP(sGroupOn As String, rList As Range, iTitle As Integer, iSurname As Integer, Optional andSymbol As String = "&")' Works similarly to a vLookup
' Returns the names grouped on the initial string - e.g. Cabin 1 - Mr & Mrs Smith
' Could be cabin/room number or booking reference.
' As with vLookup, the groupOn string must be in the first column of the range 'list'
'
' Can handle up to 4 persons per group
'
' I'm not sure how to handle it if we get the entire
' Column passed in, so I'll just not allow it (although with useful error)
If rList.Rows.Count > (2 ^ 18) Then
SALULOOKUP = "#VALUE - Choose Smaller Range"
Else
Dim persons(3) As person
' rangeToCheck will be defined as the first column of the entire region being searched
Dim rangeToCheck As Range
With rList
Set rangeToCheck = rList.Worksheet.Range(.Cells(.Row, 1), .Cells(.Rows.Count, 1))
End With
' We're only interested where the first cell matches the groupOn string
' Collect all the names in to the array; nameCount is always the length of the array
Dim r As Range, personCount As Integer
personCount = 0
For Each r In rangeToCheck
If r.Value = sGroupOn Then
persons(personCount).title = r.Offset(0, iTitle - 1)
persons(personCount).surname = r.Offset(0, iSurname - 1)
personCount = personCount + 1
End If
Next r
andSymbol = " " & Trim(andSymbol) & " "
If personCount > 0 Then
' Put the people in the array in the correct order
If personCount > 1 Then Call SortTitles(persons, personCount)
Dim concatString As String
concatString = persons(0).title
If personCount > 1 Then
Dim i As Integer
For i = 1 To personCount - 1
If persons(i).surname = persons(i - 1).surname Then
concatString = concatString & andSymbol & persons(i).title
Else
concatString = concatString & " " & persons(i - 1).surname & andSymbol & persons(i).title
End If
Next i
End If
concatString = concatString & " " & persons(personCount - 1).surname
SALULOOKUP = Trim(concatString)
Else
' personCount < 1 therefore didn't find any people with a matching ref
SALULOOKUP = "#N/A"
End If
End If
End Function
Private Sub SortTitles(ByRef persons() As person, ByVal personCount As Integer)
' Sorts the array by their titles i.e. Mr before Mrs; Lord before Mr etc etc
Dim noChanges As Boolean
Do
noChanges = True
Dim i As Integer
For i = 1 To personCount - 1
If ScoreTitle(persons(i).title) < ScoreTitle(persons(i - 1).title) Then
Call SwopElements(persons, i - 1, i)
noChanges = False
End If
Next i
Loop Until (noChanges Or personCount = 2)
End Sub
Private Function ScoreTitle(sTitle As String) As Integer
' Lower iPriority scores will be sorted to first
Dim iPriority As Integer
Select Case sTitle
Case "Lord"
iPriority = 10
Case "Sir"
iPriority = 20
Case "Dr"
iPriority = 30
Case "Prof"
iPriority = 40
Case "Rev"
iPriority = 50
Case "Mr"
iPriority = 60
Case "Lady"
iPriority = 70
Case "Mrs"
iPriority = 80
Case "Ms"
iPriority = 90
Case "Miss"
iPriority = 100
End Select
ScoreTitle = iPriority
End Function
Private Sub SwopElements(ByRef persons() As person, i1 As Integer, i2 As Integer)
' Swops two elements in a person array of any size
Dim temp As person
temp.title = persons(i1).title
temp.surname = persons(i1).surname
persons(i1).title = persons(i2).title
persons(i1).surname = persons(i2).surname
persons(i2).title = temp.title
persons(i2).surname = temp.surname
End SubThanks for any feedback!
/AJ
