Option Explicit
'-- http://www.mvps.org/dmcritchie/excel/proper.htm
'-- http://www.mvps.org/dmcritchie/excel/code/proper.txt
Sub reset_things()
   If Application.CommandBars(1).Enabled = False Then
      Application.CommandBars(1).Enabled = True 'menu bar
      MsgBox "Application.CommandBars(1).Enabled  --  reset to True"
   End If 
   If Application.CommandBars("Cell").Enabled = False Then
      Application.CommandBars("Cell").Enabled = True 'rclick cell
      MsgBox "Application.CommandBars(""cell"").Enabled  --  reset to True"
   End If
   If Application.CommandBars("PLY").Enabled = False Then
      Application.CommandBars("PLY").Enabled = True  'rclick ws tab
      MsgBox "Application.CommandBars(""PLY"").Enabled --  reset to True"
   End If
   If Application.CommandBars("Toolbar List").Enabled <> True Then
      Application.CommandBars("Toolbar List").Enabled = True
      MsgBox "Application.CommandBars(""Toolbar List"").Enabled -- reset to True"
   End If
   If Application.EnableEvents <> True Then
      Application.EnableEvents = True
      MsgBox "Application.EnableEvents reset to True"
   End If
   If Application.ScreenUpdating <> True Then
      Application.ScreenUpdating = True
      MsgBox "Application.ScreenUpdating reset to True"
   End If
   If Application.Calculation <> xlCalculationAutomatic Then
     ' MsgBox "Application.Calcution not automatic was " & application.caluwas  reset to True"
      Application.Calculation = xlCalculationAutomatic
   End If
End Sub


   Sub Proper_case()
      '-- This macro is invoked by you -- i.e. from Macro Dialog (Alt+F8)
      Proper_Case_Inner    'The macro you invoke from a menu is Proper_Case
   End Sub
   Sub Proper_Case_Inner(Optional mySelection As String)
     Application.ScreenUpdating = False
     Application.Calculation = xlCalculationManual
     Dim cell As Range
     Dim rng As Range
     On Error Resume Next   'In case no cells in selection
     If mySelection = "" Then Set rng = Selection _
         Else Set rng = Range(mySelection)
     For Each cell In Intersect(rng, _
            rng.SpecialCells(xlConstants, xlTextValues))
        cell.Formula = StrConv(cell.Formula, vbProperCase)
        '--- this is where you would code generalized changes for lastname
        '--- applied to names beginning in position 1 of cell
        If Left(cell.Value, 2) = "Mc" Then cell.Value = _
           "Mc" & UCase(Mid(cell.Value, 3, 1)) & Mid(cell.Value, 4, 99)
        If Left(cell.Value, 3) = "Mac" _
               And Left(cell.Value, 4) <> "Mack" Then cell.Value = _
           "Mac" & UCase(Mid(cell.Value, 4, 1)) & Mid(cell.Value, 5, 99)
           '-- do not change Mack   Mackey  Mackney  or any Mack...
        If Left(cell.Value, 2) = "O'" Then cell.Value = _
           "O'" & UCase(Mid(cell.Value, 3, 1)) & Mid(cell.Value, 4, 99)
        If Left(cell.Value, 8) = "Van Den " Then cell.Value = _
            "van den  " & Mid(cell.Value, 9, 99)
        If Left(cell.Value, 8) = "Van Der " Then cell.Value = _
           "van der " & Mid(cell.Value, 9, 99)
        '-- single parts after those with two part prefixes
        If Left(cell.Value, 3) =  "Vd " Then cell.Value = _
            "vd " & Mid(cell.Value, 4, 99)
        If Left(cell.Value, 4) =  "V/D " Then cell.Value = _
            "v/d " & Mid(cell.Value, 5, 99)
        If Left(cell.Value, 4) =  "V.D " Then cell.Value = _
            "v.d " & Mid(cell.Value, 5, 99)
        If Left(cell.Value, 3) = "De " Then cell.Value = _
           "de " & Mid(cell.Value, 4, 99)
        If Left(cell.Value, 4) = "Van " Then cell.Value = _
           "van " & Mid(cell.Value, 5, 99)
        If Left(cell.Value, 4) = "Von " Then cell.Value = _
           "von " & Mid(cell.Value, 5, 99)
     Next
     '-- some specific text changes to lowercase, not in first position
     rng.Replace what:=" a ", replacement:=" a ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" and ", replacement:=" and ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" at ", replacement:=" at ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" for ", replacement:=" for ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" from ", replacement:=" from ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" in ", replacement:=" in ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" of ", replacement:=" of ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" on ", replacement:=" on ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     rng.Replace what:=" the ", replacement:=" the ", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     '--- This is where you would code specific name changes
     '--- regardless of position of character string in the cell
     rng.Replace what:="mcritchie", replacement:="McRitchie", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
     CapWords (mySelection)  'activate if you want to run macro
  End Sub
Sub CapWords(Optional mySelection As String)
    'Expect all substitutions here would be to capitals
    'not necessarily limited to words
    Dim savCalc As Long, savScrnUD As Boolean
    savCalc = Application.Calculation
    savScrnUD = Application.ScreenUpdating
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Dim rng As Range
    On Error GoTo done   'In case no cells in selection
    If mySelection = "" Then Set rng = Selection _
         Else: Set rng = Range(mySelection)
    rng.Replace what:="IBM", replacement:="IBM", _
       lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False
done:
    Application.Calculation = savCalc
    Application.ScreenUpdating = savScrnUD
End Sub
Sub MakeProper_Quick_test()
    Range("A1").Formula = "=""asdf ""&ADDRESS(ROW(),COLUMN(),4)&"" qwer"""
    Dim i As Long
    i = InputBox("type 1 to convert all to values", "values", 1)
    If i = 1 Then
        Cells.Copy
        Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
    End If
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:H1"), Type:=xlFillDefault
    Range("A1:H1").Select
    Selection.AutoFill Destination:=Range("A1:H29"), Type:=xlFillDefault
    Range("A1:H29").Select
    Range("B5:F17,H6:H12,D21:D25,G20:G26,B23:B27").Select
    Range("B23").Activate
    Application.Run "MakeProper_Quick"
End Sub
 
Sub MakeProper_Quick()
 'Dave Peterson, 2003-03-21, misc,  no loop required...
 '-- doesn't work with application.upper and application.lower
    Application.ScreenUpdating = False
    Dim myRng As Range
    Dim myArea As Range
    On Error Resume Next
    Set myRng = Intersect(Selection, ActiveSheet.UsedRange)
    If myRng Is Nothing Then
        MsgBox "Nothing in intersect range"
    Else
        For Each myArea In myRng.Areas
            myArea.Formula = Application.Proper(myArea.Formula)
        Next myArea
    End If
    Application.ScreenUpdating = True
End Sub

Sub Lower_Case()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual          'in XL97
   Dim cell As Range
   On Error Resume Next   'In case no cells in selection
   For Each cell In Intersect(Selection, _
          Selection.SpecialCells(xlConstants, xlTextValues))
      cell.Formula = LCase(cell.Formula)
   Next
   Application.Calculation = xlCalculationAutomatic     'in XL97
   Application.ScreenUpdating = True
End Sub
Sub Upper_Case()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Dim cell As Range
   On Error Resume Next   'In case no cells in selection
   For Each cell In Intersect(Selection, _
          Selection.SpecialCells(xlConstants, xlTextValues))
      cell.Formula = UCase(cell.Formula)
   Next
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub

Sub Upper_Case_ALL()
    'David McRitchie, programming, 2003-03-07
    Dim rng1 As Range, rng2 As Range, bigrange As Range
    Dim cell As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
    Set rng1 = Intersect(Selection, _
       Selection.SpecialCells(xlCellTypeConstants))
    Set rng2 = Intersect(Selection, _
       Selection.SpecialCells(xlCellTypeFormulas))
    On Error GoTo 0
    If rng1 Is Nothing Then
       Set bigrange = rng2
    ElseIf rng2 Is Nothing Then
       Set bigrange = rng1
    Else
       Set bigrange = Union(rng1, rng2)
    End If
    If bigrange Is Nothing Then
       MsgBox "All cells in range are EMPTY"
       GoTo done
    End If
    For Each cell In bigrange
       cell.Formula = UCase(cell.Formula)
    Next cell
done:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


Sub Formulas_to_Values()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Dim cell As Range
   On Error Resume Next   'In case no cells in selection
   For Each cell In Selection.SpecialCells(xlFormulas)
      cell.Value = cell.Value
      If Trim(cell.Value) = "" Then cell.Formula = ""
   Next cell
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub

Sub ClearNumberConstants()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Dim cell As Range
   On Error Resume Next   'In case no such cells in selection
   For Each cell In Intersect(Selection, _
       Selection.SpecialCells(xlConstants, xlNumbers))
      cell.Formula = ""
   Next cell
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub

Sub FindFirstChar() '--Optional firstChar As String)
   Dim cell As Range
   '-- dim firstChar As String
   If firstChar = "" Then _
   firstChar = UCase(InputBox("Supply prefix character(s) " _
      & "to find first occurence", "Find First Char(s)", "W"))
   If firstChar = "" Then Exit Sub

   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual     'in XL97
   On Error Resume Next   'In case no cells in selection
   For Each cell In Intersect(Selection, _
          Selection.SpecialCells(xlConstants, xlTextValues))
       If Left(UCase(cell), Len(firstChar)) = firstChar Then
          cell.Activate
          GoTo leavemacro
       End If
   Next cell
leavemacro:
   Application.Calculation = xlCalculationAutomatic  'in XL97
   Application.ScreenUpdating = True
End Sub