Title Case

[adam087]

Afternoon

I'm posting this UDF here in the hope that...
- it may be useful to other people
- someone else may know a better or more elegant solution

It works like UPPER, LOWER and PROPER to modify a text string.
Effectively a refined PROPER where it converts to Title Case but does not make small words (such as 'the', 'for' or 'a') in to upper case, but does capitalise both hyphenated words, and some other things like that.

There's a lot of looping which makes it quite slow when used on large data. Hence I'd like a more elegant solution and would recommend its use sparingly, and then Copy --> Paste Values to reduce overhead in your Workbook.

Option Explicit

'Contains all the words that don't need capitalising, can be modified to suit
Private Const SMALL_WORDS As String = "a the with on of and au in for to an is"

Public Function TITLE(ByVal textToChange As String) As String
'Takes an input of text, which can be referenced from a cell, and returns that same
'text in TITLE CASE where most words are capitalised but some are not (such as 'a')
'and hyphenated words, for example, are also capiliatised on both words.

    Dim myDict          As Object
    Dim i               As Integer
    Dim thisWord        As String
    Dim countWords      As Long
    Dim str             As String

    Set myDict = CreateObject("scripting.dictionary")
    countWords = 0
    
    For i = 1 To Len(textToChange)
    
        Select Case Mid(textToChange, i, 1)
        Case " "
            If thisWord <> "" Then
                
                If IsSmallWord(thisWord) And countWords > 0 Then
                    myDict.Add countWords + 1, LCase(thisWord)
                Else
                    myDict.Add countWords + 1, PCase(thisWord)
                End If
                
                countWords = countWords + 1
                thisWord = ""
                
            End If
        
        Case Chr(10)
            If thisWord <> "" Then
                
                If IsSmallWord(thisWord) And countWords > 0 Then
                    myDict.Add countWords + 1, LCase(thisWord)
                Else
                    myDict.Add countWords + 1, PCase(thisWord)
                End If
                
                countWords = countWords + 1
                thisWord = ""
                
                myDict.Add countWords + 1, Chr(10)
                countWords = countWords + 1
                
            End If
            
        Case Else
            thisWord = thisWord & Mid(textToChange, i, 1)
            
        End Select
    Next i
    'Off by one check
    If thisWord <> "" Then
    
        If IsSmallWord(thisWord) Then
            myDict.Add countWords + 1, LCase(thisWord)
        Else
            myDict.Add countWords + 1, PCase(thisWord)
        End If
        
        countWords = countWords + 1
        
    End If
    For i = 1 To countWords
    
        If myDict(i) = Chr(10) Then
            str = Trim(str) & vbNewLine
        Else
            str = str & myDict(i) & " "
        End If
    
    Next i
    
    'Couple of extra checks
    str = Replace(str, "D'", "d'")
    str = Replace(str, "L'", "l'")
    
    'Return the value
    TITLE = Trim(str)

End Function

Private Function IsSmallWord(ByVal wordToCheck As String) As Boolean
'Checks if a word is designated a small word and therefore doesn't need capitalisation
'SMALL_WORDS is a Private Const defined at the top of the module
    If InStr(1, SMALL_WORDS, wordToCheck) > 0 Then IsSmallWord = True Else IsSmallWord = False
End Function

Private Function PCase(ByVal wordToCheck As String) As String

    Dim i           As Integer
    Dim str         As String
    Dim nextCap     As Boolean
       
    nextCap = True
    str = ""
    
    For i = 1 To Len(wordToCheck)
    
        Select Case Asc(Mid(wordToCheck, i, 1))
        Case 65 To 90, 97 To 122, 192 To 255
            If nextCap Then
                str = str & UCase(Mid(wordToCheck, i, 1))
                nextCap = False
            Else
                str = str & LCase(Mid(wordToCheck, i, 1))
                nextCap = False
            End If
            
        Case 6, 33, 39, 34, 40, 42, 43, 45, 46, 47, 96, 147, 148, 173
            str = str & Mid(wordToCheck, i, 1)
            nextCap = True
            
        Case Else
            str = str & Mid(wordToCheck, i, 1)
            nextCap = False
            
        End Select
        
    Next i
    
    PCase = str

End Function

Public Sub DescribeFunction_TITLE()
'Adds the function information to the UDF library so arguments can be seen in the Function dialog box

    Dim FuncName As String
    Dim FuncDesc As String
    Dim Category As String
    Dim ArgDesc(1 To 5) As String
    
    FuncName = "TITLE"
    FuncDesc = "Takes an input of text and returns most words capitalised but some are not (such as 'the' or 'for') and hyphenated words, for example, are also capiliatised on both words."
    Category = 7 'Text category
    ArgDesc(1) = "is the text to convert to title case"
       
    Application.MacroOptions _
        Macro:=FuncName, _
        Description:=FuncDesc, _
        Category:=Category, _
        ArgumentDescriptions:=ArgDesc
        
End Sub

Any feedback gratefully received.
/AJ

 

[adam087]

I love the simplicity But it doesn't appear to leave the small words lower case. It nails the hyphenation though.

/AJ

 

[Scott Huish]

I fixed that.

Private Const SMALL_WORDS As String = "a the with on of and au in for to an is"

Function changecase(r As String, caseoption As Long)
Dim s As String, t, u As Long, v
t = Split(r, "-")
For u = 0 To UBound(t)
    t(u) = StrConv(t(u), caseoption)
Next
s = Join(t, "-")
For Each v In Split(SMALL_WORDS)
    s = Replace(s, UCase(" " & v & " "), LCase(" " & v & " "))
Next
changecase = s
End Function

Excel Workbook
	G	H
1	I have a roller-skate	I HAVE a ROLLER-SKATE
2		i have a roller-skate
3		I Have a Roller-Skate
Sheet1