Toggle Text Case
Wed Sep 08 2021 06:03:58 GMT+0000 (UTC)
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
Comments