Title Case Macro

[bkanne]

I'm hoping to get assistance writing a macro that can change the case of text in selected cells. Ideally, the macro will be able to:

• Capitalize the first letter of words in a selected range, BUT ALSO

• Have the flexibility to exclude certain words (like articles and prepositions, such as "of", "on", "at", "the", and other acronyms such as "IBM") which can easily be added to the code)

- To add additional complexity, if the prepositions or selected words appear at the beginning of the text, than they should be ignored / remain capitalized - "e.g. The Man Went to the Store"
​

So far, I've put together the following simple construct:

Sub Proper_Case()
  Dim rng As Range, cell As Range
   Set rng = Selection
      ' Loop to cycle through each cell in the specified range.
   For Each x In rng
             x.Value = Application.Proper(x.Value)
   Next
End Sub

This has the limitation of only being able to capitalize the first word of each sentence / cannot make exceptions.

Can a more skilled VBAer please help me adapt the code to meet the criteria described above? Thank you so much for any assistance as always.
​

 

[Hui]

Sub Proper_Case()
  Dim rng As Range
  Set rng = Selection
  Dim Originals As Variant
  Dim Replacements As Variant
  Dim tmp As String

  Originals = Array(" Or ", " To ", " On ", " Of ", " At ", " The ")
  Replacements = Array(" or ", " to ", " on ", " of ", " at ", " the ")

  For Each cell In rng
      tmp = StrConv(cell.Value, vbProperCase)

    For i = 0 To UBound(Originals, 1)
        tmp = Replace(tmp, Originals(i), Replacements(i))
    Next i
    cell.Value = tmp
  Next

End Sub

note the leading and trailing spaces around the words, to stop the start of words being replaced, like Today

 

[bkanne]

Thank you for the quick response! This is quite clever. Thank you so much! I will use in practice and follow up with any additional questions.

I've run a few test cases and it seems to work perfectly.

 

[Hui]

I have just changed one line above
It will run a bit faster now

muchas gracias

 

[Hui]

and now with an expanded list and better coding

Sub Proper_Case()
  Dim myCell As Range
  Dim Originals As Variant
  Dim Replacements As Variant
  Dim tmp As String

  Originals = Array(" A ", " An ", " And ", " In ", " Is ", " Of ", " Or ", " The ", " To ", " Was ", " With ")
  Replacements = Array(" a ", " an ", " and ", " in ", " is ", " of ", " or ", " the ", " to ", " was ", " with ")

  For Each myCell In Selection
    tmp = StrConv(myCell.Value, vbProperCase)
    For i = 0 To UBound(Originals, 1)
        tmp = Replace(tmp, Originals(i), Replacements(i))
    Next i
    myCell.Value = tmp
  Next

End Sub

 

[bkanne]

Just fantastic. Thank you again!

Question about one more condition.

If a word is greater than 3 letters or greater and is already in ALL CAPS, is it possible to IGNORE without having to enter the words into the arrays? For example, "IBM" , "AAPL", or "MSFT" and other similarly formatted text should remain all caps no matter what.

Not a critical aspect, but would be a helpful nuance.

 

[bkanne]

Actually, I think the easiest way to do this is add them to the array, but just leave out the leading and trailing spaces, so that they are always capitalized. For example, "Ibm" would be written into the Originals Array, and "IBM" would be in the replacements. I think this should pick up all the nuances / adapt.

So thank you please don't worry about the last post!

 

[Hui]

I would do that as a separate set of arrays
Purely so that it is easier to see what is going on and manage

 

[Hui]

Here is an even simpler version, incorporating the companies

Sub Proper_Case()
  Dim myCell As Range
  Dim Originals As Variant, OrigComp As Variant
 
  Dim tmp As String

  Originals = Array(" A ", " An ", " And ", " In ", " Is ", " Of ", " Or ", " The ", " To ", " Was ", " With ")
  OrigComp = Array("Aapl", "Ibm", "Msft")

  For Each myCell In Selection
    'Convert to Proper Case
    tmp = StrConv(myCell.Value, vbProperCase)
   
    'Replace joining words
    For i = 0 To UBound(Originals, 1)
        tmp = Replace(tmp, Originals(i), LCase(Originals(i)))
    Next i
   
    'Replace companies
    For i = 0 To UBound(OrigComp, 1)
        tmp = Replace(tmp, OrigComp(i), UCase(OrigComp(i)))
    Next i
   
    myCell.Value = tmp
  Next
End Sub