Function ConvertRegistr(sString As String, Tip As Byte) As String
'Tip = 1 - ВСЕ ПРОПИСНЫЕ
'Tip = 2 - все строчные
'Tip = 3 - Начинать С Прописных
'Tip = 4 - Как в предложениях
'Tip = 5 - иЗМЕНИТЬ рЕГИСТР
Dim i&
      If Tip = 4 Then
          ConvertRegistr = StrConv(sString, 2)
          Mid$(ConvertRegistr, 1, 1) = UCase(Mid$(ConvertRegistr, 1, 1))
      ElseIf Tip > 4 Then
          For i = 1 To Len(sString)
              Mid$(sString, i, 1) = IIf(Mid$(sString, i, 1) = UCase(Mid$(sString, i, 1)), _
                     LCase(Mid$(sString, i, 1)), UCase(Mid$(sString, i, 1)))
          Next
          ConvertRegistr = sString
      Else
          ConvertRegistr = StrConv(sString, Tip)
      End If
End Function

Sub ConvRegistr1()
      Dim DataRng As Range, cell As Range, Tip As Byte
      On Error Resume Next
      Tip = InputBox("ВСЕ ПРОПИСНЫЕ = 1" & vbLf & "все строчные = 2" & vbLf & _
                     "Начинать С Прописных = 3" & vbLf & "Как в предложениях = 4" _
                   & vbLf & "иЗМЕНИТЬ рЕГИСТР = 5", "Выбор типа конвертации", 2)
      Set DataRng = Intersect(Selection, ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible))
      If MsgBox("Заменить формулы на значения?", _
                vbYesNo + vbQuestion, "Выбор типа конвертации") = vbNo Then
          Set DataRng = Intersect(DataRng, ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants))
      End If
      With Application
      ' На всякий случай, вдруг надо. =)
      .EnableEvents = False: .ScreenUpdating = False
      For Each cell In DataRng
          cell.Value = ConvertRegistr(cell.Value, Tip)
      Next cell
      .EnableEvents = True: .ScreenUpdating = True
      End With
End Sub

Sub ConvRegistr()
      Dim DataRng As Range, Tip As Byte
      Dim arr(), arrCel(), lrA&, i&, j&
     On Error Resume Next
      Tip = InputBox("ВСЕ ПРОПИСНЫЕ = 1" & vbLf & "все строчные = 2" & vbLf & _
                     "Начинать С Прописных = 3" & vbLf & "Как в предложениях = 4" _
                   & vbLf & "иЗМЕНИТЬ рЕГИСТР = 5", "Выбор типа конвертации", 2)
      Set DataRng = Intersect(Selection, ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible))
          If MsgBox("Заменить формулы на значения?", _
                         vbYesNo + vbQuestion, "Выбор типа конвертации") = vbNo Then
              Set DataRng = Intersect(DataRng, ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants))
          End If

      ReDim arrCel(1 To DataRng.Areas.Count, 1 To 2)
      For lrA = 1 To DataRng.Areas.Count
          If DataRng.Areas(lrA).Cells.Count = 1 Then
              ReDim arr(1 To 1, 1 To 1)
              arr(1, 1) = DataRng.Areas(lrA).Value
          Else
              arr = DataRng.Areas(lrA).Value
          End If
          For i = 1 To UBound(arr)
              For j = 1 To UBound(arr, 2)
                  arr(i, j) = ConvertRegistr(CStr(arr(i, j)), Tip)
              Next
          Next
          arrCel(lrA, 1) = DataRng.Areas(lrA).Address
          arrCel(lrA, 2) = arr
      Next
      With Application
      ' На всякий случай, вдруг надо. =)
      .EnableEvents = False: .ScreenUpdating = False
      For i = 1 To UBound(arrCel)
          Range(arrCel(i, 1)) = arrCel(i, 2)
      Next
      .EnableEvents = True: .ScreenUpdating = True
      End With
End Sub