Toggle Text Case

PHOTO EMBED

Wed Sep 08 2021 06:03:58 GMT+0000 (UTC)

Saved by @Darkleech #vba

Sub toggle_case_shortcut() 'Ctrl+Shift+C 'Toggle Text Case
'IS UPPER CASE - convert to lower case"
If ActiveCell.Value = UCase(ActiveCell) Then
Dim rngRectangle As Range, rngRows As Range, rngcolumns As Range
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),lower(" & rngRectangle.Address & ")))")
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
'is lower case - convert to Proper Case"
ElseIf ActiveCell.Value = LCase(ActiveCell) Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Selection.Replace What:="-", Replacement:=" - ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="'", Replacement:=" ' ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="`", Replacement:=" ' ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="  ' t", Replacement:=" 't", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),trim(" & rngRectangle.Address & ")))")
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),proper(" & rngRectangle.Address & ")))")
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Ii"",REPLACE(@,LEN(@)-2,3,"" II""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,4)="" Iii"",REPLACE(@,LEN(@)-2,4,"" III""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Iv"",REPLACE(@,LEN(@)-2,3,"" IV""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Vi"",REPLACE(@,LEN(@)-2,3,"" VI""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,4)="" Vii"",REPLACE(@,LEN(@)-2,4,"" VII""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,5)="" Viii"",REPLACE(@,LEN(@)-2,5,"" VIII""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Ix"",REPLACE(@,LEN(@)-2,3,"" IX""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Mp"",REPLACE(@,LEN(@)-2,3,"" MP""),@)", "@", Selection.Address))
Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows
For Each c In Selection
If UCase(Left(c, 2)) = "MC" And Mid(c, 3, 1) <> "" Then
c.Value = Application.Proper(Left(c, 2)) & Application.Proper(Mid(c, 3, Len(c) - 2))
End If
Next c
Selection.Replace What:=" - ", Replacement:="-", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:=" ' ", Replacement:="'", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="1St", Replacement:="1st", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="2Nd", Replacement:="2nd", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="3Rd", Replacement:="3rd", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="4Th", Replacement:="4th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="5Th", Replacement:="5th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="6Th", Replacement:="6th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="7Th", Replacement:="7th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="8Th", Replacement:="8th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="9Th", Replacement:="9th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="10Th", Replacement:="10th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="11Th", Replacement:="11th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="12Th", Replacement:="12th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="13Th", Replacement:="13th", LookAt:=xlPart, MatchCase:=True
If Left(cel, 1) <> "0" Then
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),clean(" & rngRectangle.Address & ")))")
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),trim(" & rngRectangle.Address & ")))")
End If
Application.DisplayAlerts = True
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
'IS Proper Case - convert to UPPER CASE"
Else
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),upper(" & rngRectangle.Address & ")))")
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
End If
End Sub
content_copyCOPY