Нужно сделать, чтобы на одном листе я вводил основной текст например "Общество с ограниченной ответственностью" в на 2 листе каждая буква была в отдельной клетке
тоже озадачился этим вопросом, набросал макрос, только не для Экселя, а для Ворда. Кому нужно, вот код:
[vba]
Код
Sub каждую_букву_в_отдельную_ячейку()
Dim sl, Answer As String, i As Long
' уведомление для пользователя: Answer = MsgBox("Для преобразования текста " & vbCrLf & _ "НУЖНЫЙ ТЕКСТ ДОЛЖЕН БЫТЬ ВЫДЕЛЕН" & vbCrLf & _ "(мышкой или стрелочками при нажатой клавише Shift)." & vbCrLf & vbCrLf & _ "Для подтверждения запуска макроса нажмите кнопку " & Chr$(34) & "ОК" & Chr$(34) _ , vbOKCancel + vbInformation, "Запущен макрос " & Chr$(34) & "Каждую букву - в отдельную ячейку" & Chr$(34)) If Answer = vbCancel Then Exit Sub
' отключить перерисовку (обновление) экрана после каждого выполненного действия: Application.ScreenUpdating = False
'== вставка сепараторов после каждого символа по всему тексту ==================================== sl = Len(Selection.Text) Selection.MoveLeft
For i = 1 To sl Selection.MoveRight Unit:=wdCharacter, Count:=1 If Selection.Text = " " Then Selection.Text = Replace(Selection.Text, Selection.Text, "°" & vbCrLf) Selection.MoveRight Unit:=wdCharacter, Count:=2 Selection.TypeBackspace i = i + 1 Else Selection.TypeText Text:="°" End If Next '===========================================================================================
'переход в начало документа (первую ячейку первой строки таблицы): Selection.StartOf Unit:=wdStory, Extend:=wdMove
' выделить весь текст Selection.WholeStory Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
' преобразовать выделенный текст в таблицу: Selection.ConvertToTable Separator:="°", AutoFitBehavior:=wdAutoFitFixed With Selection.Tables(1) .Style = "Сетка таблицы" .ApplyStyleHeadingRows = True .ApplyStyleLastRow = False .ApplyStyleFirstColumn = True .ApplyStyleLastColumn = False .Rows.HeightRule = wdRowHeightAtLeast .Rows.Height = CentimetersToPoints(0.7) .Columns.PreferredWidthType = wdPreferredWidthPoints .Columns.PreferredWidth = CentimetersToPoints(0.7) End With
'переход в конец документа: Selection.EndOf Unit:=wdStory, Extend:=wdMove
Нужно сделать, чтобы на одном листе я вводил основной текст например "Общество с ограниченной ответственностью" в на 2 листе каждая буква была в отдельной клетке
тоже озадачился этим вопросом, набросал макрос, только не для Экселя, а для Ворда. Кому нужно, вот код:
[vba]
Код
Sub каждую_букву_в_отдельную_ячейку()
Dim sl, Answer As String, i As Long
' уведомление для пользователя: Answer = MsgBox("Для преобразования текста " & vbCrLf & _ "НУЖНЫЙ ТЕКСТ ДОЛЖЕН БЫТЬ ВЫДЕЛЕН" & vbCrLf & _ "(мышкой или стрелочками при нажатой клавише Shift)." & vbCrLf & vbCrLf & _ "Для подтверждения запуска макроса нажмите кнопку " & Chr$(34) & "ОК" & Chr$(34) _ , vbOKCancel + vbInformation, "Запущен макрос " & Chr$(34) & "Каждую букву - в отдельную ячейку" & Chr$(34)) If Answer = vbCancel Then Exit Sub
' отключить перерисовку (обновление) экрана после каждого выполненного действия: Application.ScreenUpdating = False
'== вставка сепараторов после каждого символа по всему тексту ==================================== sl = Len(Selection.Text) Selection.MoveLeft
For i = 1 To sl Selection.MoveRight Unit:=wdCharacter, Count:=1 If Selection.Text = " " Then Selection.Text = Replace(Selection.Text, Selection.Text, "°" & vbCrLf) Selection.MoveRight Unit:=wdCharacter, Count:=2 Selection.TypeBackspace i = i + 1 Else Selection.TypeText Text:="°" End If Next '===========================================================================================
'переход в начало документа (первую ячейку первой строки таблицы): Selection.StartOf Unit:=wdStory, Extend:=wdMove
' выделить весь текст Selection.WholeStory Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
' преобразовать выделенный текст в таблицу: Selection.ConvertToTable Separator:="°", AutoFitBehavior:=wdAutoFitFixed With Selection.Tables(1) .Style = "Сетка таблицы" .ApplyStyleHeadingRows = True .ApplyStyleLastRow = False .ApplyStyleFirstColumn = True .ApplyStyleLastColumn = False .Rows.HeightRule = wdRowHeightAtLeast .Rows.Height = CentimetersToPoints(0.7) .Columns.PreferredWidthType = wdPreferredWidthPoints .Columns.PreferredWidth = CentimetersToPoints(0.7) End With
'переход в конец документа: Selection.EndOf Unit:=wdStory, Extend:=wdMove