Sub CaseNextChar() ' Paul Beverley - Version 18.04.19 ' Changes case of the next character/selection trackIt = True trackIfSelected = False myShow = ActiveWindow.View.ShowRevisionsAndComments myTrack = ActiveDocument.TrackRevisions ' Don't track case change if TC is OFF If myTrack = False Then trackIt = False ' If an area of text is NOT selected ... If Selection.End = Selection.Start Then If trackIt = False Then ActiveDocument.TrackRevisions = False Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend Selection.Range.Case = wdToggleCase Selection.MoveRight Unit:=wdCharacter, Count:=1 Else myChar = Selection Selection.MoveRight Unit:=wdCharacter, Count:=1 char = Asc(myChar) If char > 64 And char < 123 Then If char > 96 Then myChar = UCase(myChar) Else myChar = LCase(myChar) End If Selection.TypeBackspace Selection.TypeText Text:=myChar End If End If Else ' If an area of text is selected ... If trackIfSelected = False Then trackIt = False If Selection.Information(wdWithInTable) = True Then If Selection.Range.Case = wdLowerCase Then Selection.Range.Case = wdUpperCase Else Selection.Range.Case = wdLowerCase End If Else myText = Selection voteUpper = 0 voteLower = 0 For myCount = 1 To Len(myText) myChar = Asc(Mid(myText, myCount, 1)) If myChar > 96 And myChar < 123 Then voteLower = voteLower + 1 If myChar > 64 And myChar < 91 Then voteUpper = voteUpper + 1 Next myCount myUpper = (voteUpper > voteLower) If voteLower = 0 Then myUpper = False If trackIt = False Then ActiveDocument.TrackRevisions = False If myUpper = True Then Selection.Range.Case = wdUpperCase Else Set rng = Selection For Each myWd In rng.Words If Len(myWd) > 1 Then myCh1 = Left(myWd, 1) myCh2 = Mid(myWd, 2, 1) If LCase(myCh1) <> myCh1 And UCase(myCh2) <> myCh2 And _ myWd.Start >= rng.Start Then _ myWd.Case = wdLowerCase End If Next myWd End If If Selection = myText Then Selection.Range.Case = wdUpperCase If Selection = myText Then Selection.Range.Case = wdLowerCase Else startWas = Selection.Start If myUpper = True Then myTextNew = UCase(myText) Else myTextNew = LCase(myText) End If If myTextNew = myText Then myTextNew = UCase(myText) If myTextNew = myText Then myTextNew = LCase(myText) wasBold = Selection.Font.Bold wasItalic = Selection.Font.Italic Selection.Delete Selection.TypeText Text:=myTextNew Selection.Start = startWas If wasBold Then Selection.Font.Bold = True If wasItalic Then Selection.Font.Italic = True End If End If End If ActiveDocument.TrackRevisions = myTrack ActiveWindow.View.ShowRevisionsAndComments = myShow End Sub