Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Регистр - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Регистр (Изменение регистра текста.)
Регистр
RAN Дата: Воскресенье, 02.12.2012, 21:08 | Сообщение № 1
Группа: Друзья
Ранг: Экселист
Сообщений: 5564
Репутация: 1111 ±
Замечаний: 0% ±

2010
Word предусматривает 5 параметров изменения регистра, а Excel всего три, и то в виде функций.
Function ConvertRegist позволяет изменять 5 параметров регистра, аналогично Word.
[vba]
Code
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
[/vba]

Процедуры на ее основе позволяют изменять регистр текста непосредственно в ячейках, в том числе и в несвязанных диапазонах.
Первая процедура вполне годится для повседневного применения.

[vba]
Code
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
[/vba]
Но если вам вдруг нужно изменить регистр сразу в 3-4 млн. ячеек, лучше применить другую процедуру. Разница в скорости ~ в 10 раз!

[vba]
Code
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
[/vba]


Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Воскресенье, 02.12.2012, 21:08
 
Ответить
СообщениеWord предусматривает 5 параметров изменения регистра, а Excel всего три, и то в виде функций.
Function ConvertRegist позволяет изменять 5 параметров регистра, аналогично Word.
[vba]
Code
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
[/vba]

Процедуры на ее основе позволяют изменять регистр текста непосредственно в ячейках, в том числе и в несвязанных диапазонах.
Первая процедура вполне годится для повседневного применения.

[vba]
Code
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
[/vba]
Но если вам вдруг нужно изменить регистр сразу в 3-4 млн. ячеек, лучше применить другую процедуру. Разница в скорости ~ в 10 раз!

[vba]
Code
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
[/vba]

Автор - RAN
Дата добавления - 02.12.2012 в 21:08
Alex_ST Дата: Понедельник, 03.12.2012, 09:03 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3156
Репутация: 601 ±
Замечаний: 0% ±

2003
Давно хотел добавить в свой Excel такую же функцию, как в Word - перебор регистров текста по кругу по нажатиям на Shift+F3
Всё руки не доходили. А оказывается, это показалось нужным не одному мне.
Надо будет посмотреть-покрутить твой вариант, Андрей, чтобы было полностью как в Word'e без задания всяких дополнительных вопросов.
Вот только дойдут ли руки? …



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Понедельник, 03.12.2012, 09:04
 
Ответить
СообщениеДавно хотел добавить в свой Excel такую же функцию, как в Word - перебор регистров текста по кругу по нажатиям на Shift+F3
Всё руки не доходили. А оказывается, это показалось нужным не одному мне.
Надо будет посмотреть-покрутить твой вариант, Андрей, чтобы было полностью как в Word'e без задания всяких дополнительных вопросов.
Вот только дойдут ли руки? …

Автор - Alex_ST
Дата добавления - 03.12.2012 в 09:03
Мир MS Excel » Вопросы и решения » Готовые решения » Регистр (Изменение регистра текста.)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!