Sub Cells_ConvertCase()
'in Tools to Format...
Dim FormatChoice As String
Dim QuestionString As String
Dim rAcells As Range, rLoopCells As Range
Dim Hack As VbMsgBoxResult
Dim varFormulas As Variant
'Check to make sure we have no formulas
On Error Resume Next
varFormulas = Selection.Cells.SpecialCells(xlCellTypeFormulas).Count
On Error GoTo 0
If varFormulas > 0 Then
MsgBox "Macro is exiting because there are" & vbCrLf & _
"formulas in the range to be worked.", vbOKOnly + vbCritical, "CAN'T PROCESS FORMULA CELLS"
Exit Sub
End If
'Set variable to needed cells
Hack = MsgBox("Do you want to convert your selection only?" & vbCrLf & _
"Select NO to convert your whole used range", vbYesNoCancel, "WARNING:Slow on Large Ranges")
On Error Resume Next 'In case of NO text constants.
Select Case Hack
Case vbYes
If Selection.Cells.Count = 1 Then
Set rAcells = Selection
Else
Set rAcells = Selection.SpecialCells(xlCellTypeConstants, xlTextValues)
End If
Case vbNo
Set rAcells = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
Case vbCancel
Exit Sub
End Select
If rAcells Is Nothing Then
MsgBox "Could not find any text."
On Error GoTo 0
Exit Sub
End If
On Error GoTo HandleErr
QuestionString = " 1 Title Case, like Joe-Bob, Mary Margaret, Don't" & vbCrLf & vbCrLf & _
" 2 Proper (AKA Title), like Joe-bob, Mary Margaret, Don'T" & vbCrLf & vbCrLf & _
" 3 UPPER, like JOE-BOB, MARY MARGARET, DON'T" & vbCrLf & vbCrLf & _
" 4 lower, like joe-bob, mary margaret,don't" & vbCrLf & vbCrLf & _
" 5 Sentence, which capitalizes the first word."
'Ask the user what format to apply
FormatChoice = InputBox(QuestionString, "Enter a Case Choice for Your Data", 0)
SpeedOn
'based on the FormatChoice, format the selected text
Select Case FormatChoice
Case 1 ' Convert to Title Case
TitleCase rAcells
Case 2 ' Convert to Proper Case
If rAcells.Count = 1 Then
rAcells.Value = StrConv(rAcells, vbProperCase)
Else
With rAcells
.Value = Evaluate("=Index(PROPER(" & .Address & "),)")
End With
End If
Case 3 ' Convert to Upper Case
If rAcells.Count = 1 Then
rAcells.Value = StrConv(rAcells, vbUpperCase)
Else
With rAcells
.Value = Evaluate("=Index(UPPER(" & .Address & "),)")
End With
End If
Case 4 ' Convert to lower Case
If rAcells.Count = 1 Then
rAcells.Value = StrConv(rAcells, vbLowerCase)
Else
With rAcells
.Value = Evaluate("=Index(LOWER(" & .Address & "),)")
End With
End If
Case 5 ' Convert to Sentence Case
If rAcells.Count = 1 Then
rAcells.Value = StrConv(rAcells, vbLowerCase)
Else
With rAcells
.Value = Evaluate("=Index(LOWER(" & .Address & "),)")
End With
End If
' code taken from http://vbamacros.blogspot.com/2007_09_01_archive.html
For Each rLoopCells In rAcells
s = rLoopCells.Value
Start = True
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
Select Case ch
Case "."
Start = True
Case "?"
Start = True
Case "a" To "z"
If Start Then ch = UCase$(ch)
Start = False
Case "A" To "Z"
If Start Then
Start = False
Else
ch = LCase$(ch)
End If
End Select
Mid$(s, i, 1) = ch
Next i
rLoopCells.Value = s
Next rLoopCells
Case Else
MsgBox "You chose to cancel, or picked an invalid choice." & vbCrLf & _
"Either way, this is Goodbye for now."
GoTo ExitSub
End Select
ExitSub:
SpeedOff
Exit Sub
HandleErr:
MsgBox "There's Been an Unexpected Error: " & Err & vbCrLf & _
Err.Description & vbCrLf & _
"Try again; if it happens again call or email John with the details."
GoTo ExitSub
End Sub
Sub TitleCase(R As Range)
' Used by Cells_ConvertCase
Dim Cell As Range
For Each Cell In Intersect(R, R.Worksheet.UsedRange)
If Not Cell.HasFormula And _
VarType(Cell.Value) = vbString And Len(Cell.Text) Then
Cell.Value = Title(Cell)
End If
Next Cell
End Sub
Function Title(ByVal ref As Range, Optional bFormal As Boolean = True) As String
' Used by Cells_ConvertCase/TitleCase
'https://excelribbon.tips.net/T010560_Making_PROPER_Skip_Certain_Words.html
'Thanks to Jim Cone who pointed out that the original function _
did not deal with hyphens & upper case words such as 'IBM' or indeed Mcs and Macs.
'Completed 5 Jan 2015
'
Dim vaArray As Variant
Dim LLo As Long, LMid As Long, LHi As Long
Dim c As String, sTemp As Variant
Dim i As Integer, iWrdCap As Variant
Dim iPos As Integer, iMc As Integer, _
iMac As Integer, iHyphen As Integer
Dim vaLCase As Variant
Dim Str As String, sChr As String
'Is there a capitalised word in the reference? e.g. IBM or BAE _
if so find out its position for later
sTemp = Split(ref, " ")
iWrdCap = ""
For i = LBound(sTemp) To UBound(sTemp)
If sTemp(i) = StrConv(sTemp(i), vbUpperCase) Then
iWrdCap = i
Exit For
End If
Next i
' Array contains terms that should be lower case
vaLCase = Array("A", "Am", "An", "And", "Be", "Do", "In", "Is", _
"Of", "On", "Or", "Than", "The", "To", "With")
If bFormal Then
c = WorksheetFunction.Proper(ref)
Else
c = StrConv(ref, vbProperCase)
End If
'=======================================
'Special Cases
iMac = InStr(1, c, "Mac")
If iMac > 0 Then
Mid(c, iMac + 3, 1) = UCase(Mid(c, iMac + 3, 1))
End If
iMc = InStr(1, c, "Mc")
If iMc > 0 Then
Mid(c, iMc + 2, 1) = UCase(Mid(c, iMc + 2, 1))
End If
iPos = InStr(1, c, "-On-")
If iPos > 0 Then
c = Replace(c, "-On-", "-on-")
End If
iHyphen = InStr(1, c, " - ")
If iHyphen > 0 Then
c = Replace(c, " - ", "-")
End If
'=======================================
'split the words into an array
vaArray = Split(c, " ")
'i ignores the first value - that should be Proper case
For i = 1 To UBound(vaArray)
LLo = LBound(vaLCase)
LHi = UBound(vaLCase)
If Right(vaArray(i), 1) Like "[',.]" Then
sChr = Left(vaArray(i), Len(vaArray(i)) - 1)
Else
sChr = vaArray(i)
End If
'Binary Search for sChr
Do Until LLo > LHi
'Find the midpoint of the array
LMid = (LLo + LHi) / 2
If sChr = vaLCase(LMid) Then
'sChr is found so return the location & quit loop
vaArray(i) = LCase(sChr)
Exit Do
ElseIf sChr < vaLCase(LMid) Then
'sFind is higher than mid-point so _
throw away the top half
LHi = LMid - 1
Else
'sFind is lower than than mid-point so _
discard the bottom half
LLo = LMid + 1
End If
Loop
Next i
' rebuild the sentence
Str = ""
For i = LBound(vaArray) To UBound(vaArray)
If i = iWrdCap Then
Str = Str & " " & UCase(vaArray(i))
Else:
Str = Str & " " & vaArray(i)
End If
Next i
'Title = Trim(Str)
Str = LateAdjustments(Trim(Str))
Title = Str
End Function
Function LateAdjustments(TheString)
'Used by Function Title, Made by Kev at
'https://www.excelforum.com/newreply.php?do=postreply&t=1216122
TheString = Replace(TheString, "'S ", "'s ", , , vbTextCompare) 'note space after 's
TheString = Replace(TheString, "'Re ", "'re ", , , vbTextCompare) 'note space after 're
TheString = Replace(TheString, "O's", "O'S", , , vbTextCompare)
TheString = Replace(TheString, "O'Clock", "o'clock", , , vbTextCompare)
TheString = Replace(TheString, "n'T", "n't", , , vbTextCompare)
TheString = Replace(TheString, "e'D", "e'd", , , vbTextCompare)
TheString = Replace(TheString, "e'Ll", "e'll", , , vbTextCompare)
TheString = Replace(TheString, "I'Ve", "I've", , , vbTextCompare)
LateAdjustments = TheString
End Function
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks