Enhanced Proper Case

[plantechbl]

Enhanced Proper Case
I am looking for a macro to enhance the "Proper" case function or
code.
What I would like to do is take a cell entry and change it to proper
case but leave certain words lower case, for example:
The quick brown fox and the hare
Changed to:
The Quick Brown Fox and the Hare
I would like to have a list of words (" and ", " the ", " of ", etc.
<the spaces assist in only changing the words within the string>) in a
sheet that I can add to to create my word exclusions, much the same
way that the networkdays function uses a list for holidays. I can
crudely accomplish this by using "Proper" then "Replace" but it would
seem that a more streamlined approach could be developed.
Thanks in advance,
Bill

 

[Gord Dibben]

Try this David McRitchie

As written will proper "The" only if it is first word of string.

Sub Exception_Click()
'David McRitchie, programming, 2003-03-07
Dim rng1 As Range, rng2 As Range, bigrange As Range
Dim Cell As Range
Dim sStr As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set rng1 = Intersect(Selection, _
Selection.SpecialCells(xlCellTypeConstants))
Set rng2 = Intersect(Selection, _
Selection.SpecialCells(xlCellTypeFormulas))
On Error GoTo 0
If rng1 Is Nothing Then
Set bigrange = rng2
ElseIf rng2 Is Nothing Then
Set bigrange = rng1
Else
Set bigrange = Union(rng1, rng2)
End If
If bigrange Is Nothing Then
MsgBox "All cells in range are EMPTY"
GoTo done
End If
For Each Cell In bigrange
Cell.Formula = Application.Proper(cell.Formula)
sStr = Application.WorksheetFunction.Proper(Cell.Formula)
sStr = Application.Substitute(sStr, " Of ", " of ")
sStr = Application.Substitute(sStr, " Is ", " is ")
sStr = Application.Substitute(sStr, " And ", " and ")
sStr = Application.Substitute(sStr, " A ", " a ")
sStr = Application.Substitute(sStr, " The ", " the ")
sStr = Application.Substitute(sStr, " An ", " an ")
sStr = Application.Substitute(sStr, "Th ", "th ")
sStr = Application.Substitute(sStr, "Nd ", "nd ")
sStr = Application.Substitute(sStr, "Rd ", "rd ")
Cell.Formula = sStr
Next Cell
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub


Gord Dibben MS Excel MVP

 

[plantechbl]

Outstanding!! This will save a lot of time standardizing some very
large excel database entries.
Thank you very much.
Another thought...Can this be turned into a UDF and used like the
other excel functions for text case?

 

[Gord Dibben]

Change to a UDF?

Not by this scribe<g>


Gord

Outstanding!! This will save a lot of time standardizing some very
large excel database entries.
Thank you very much.
Another thought...Can this be turned into a UDF and used like the
other excel functions for text case?

 

[Dave Peterson]

It looks like most of David McRitchie's code goes away:

Option Explicit
Function myProper(myCell As Range) As String
Dim sStr As String

Set myCell = myCell.Cells(1)

sStr = Application.WorksheetFunction.Proper(myCell.Value)
sStr = Application.Substitute(sStr, " Of ", " of ")
sStr = Application.Substitute(sStr, " Is ", " is ")
sStr = Application.Substitute(sStr, " And ", " and ")
sStr = Application.Substitute(sStr, " A ", " a ")
sStr = Application.Substitute(sStr, " The ", " the ")
sStr = Application.Substitute(sStr, " An ", " an ")
sStr = Application.Substitute(sStr, "Th ", "th ")
sStr = Application.Substitute(sStr, "Nd ", "nd ")
sStr = Application.Substitute(sStr, "Rd ", "rd ")

myProper = sStr

End Function

 

[Gord Dibben]

Thanks for helping out Dave.

I sure didn't know where to start with my limited VBA skills.


Gord

 

[Dave Peterson]

You're welcome, Gord.

Thanks for helping out Dave.

I sure didn't know where to start with my limited VBA skills.

Gord

 

[plantechbl]

Thanks very much to both of you! The function works great as it allows
the user to see the before and after of the cell entry. I can then
copy/paste special/values over the original entry to complete the
task. I have added some additional keywords and abbreviations that I
am finding in cleaning up my database project.

Option Explicit
Function myProper(myCell As Range) As String
Dim sStr As String


Set myCell = myCell.Cells(1)


sStr = Application.WorksheetFunction.Proper(myCell.Value)
sStr = Application.Substitute(sStr, " Of ", " of ")
sStr = Application.Substitute(sStr, " Is ", " is ")
sStr = Application.Substitute(sStr, " And ", " and ")
sStr = Application.Substitute(sStr, " A ", " a ")
sStr = Application.Substitute(sStr, " The ", " the ")
sStr = Application.Substitute(sStr, " An ", " an ")
sStr = Application.Substitute(sStr, "Th ", "th ")
sStr = Application.Substitute(sStr, "Nd ", "nd ")
sStr = Application.Substitute(sStr, "Rd ", "rd ")
sStr = Application.Substitute(sStr, " Or ", " or ")
sStr = Application.Substitute(sStr, " To ", " to ")
'Roman Numerals
sStr = Application.Substitute(sStr, " Ii ", " II ")
sStr = Application.Substitute(sStr, " Ii ", " II ")
sStr = Application.Substitute(sStr, " Iii ", " III ")
'Independent School District
sStr = Application.Substitute(sStr, " Isd ", " ISD ")
'High School
sStr = Application.Substitute(sStr, " Hs ", " HS ")
'Compass Directions
sStr = Application.Substitute(sStr, " Ne ", " NE ")
sStr = Application.Substitute(sStr, " Nw ", " NW ")
sStr = Application.Substitute(sStr, " Sw ", " SW ")
sStr = Application.Substitute(sStr, " Se ", " SE ")


myProper = sStr


End Function