Добрый день! Прошу от Вас помощи в выполнении определённой задачи, а именно необходимо текст разбить по строкам: 1. Формируется определенная ширина текста с использованием команды "Перенести текст"; 2. Сформированный текст преобразуется "как-то" с простановкой [ALT]+[ENTER] (т.е. визуальное преобразуется в физическое); 3. И сформированный текст дробится по строкам с помощью макроса (код в файле) . Вопрос, можно ли как-то системно выполнить пункт 2 и привязать к существующему макросу?
Добрый день! Прошу от Вас помощи в выполнении определённой задачи, а именно необходимо текст разбить по строкам: 1. Формируется определенная ширина текста с использованием команды "Перенести текст"; 2. Сформированный текст преобразуется "как-то" с простановкой [ALT]+[ENTER] (т.е. визуальное преобразуется в физическое); 3. И сформированный текст дробится по строкам с помощью макроса (код в файле) . Вопрос, можно ли как-то системно выполнить пункт 2 и привязать к существующему макросу?4step
4step, Добрый день. Нашел где-то на просторах интернета... Выделить таблицу "Вспомогательная" и применить следующий макрос [vba]
Код
Sub Split_By_Rows() Dim cell As Range, n As Integer
Set cell = ActiveCell
For i = 1 To Selection.Rows.Count ar = Split(cell, Chr(10)) 'делим текст по переносам в массив n = UBound(ar) 'определяем кол-во фрагментов cell.Offset(1, 0).Resize(n, 1).EntireRow.Insert 'вставляем пустые строки ниже cell.Resize(n + 1, 1) = WorksheetFunction.Transpose(ar) 'вводим в них данные из массива Set cell = cell.Offset(n + 1, 0) 'сдвигаемся на следующую ячейку Next i End Sub
[/vba]
Добавлено: Хммм... Данный код уже есть в листе "Должно быть" Сразу не понял задачу...
4step, Добрый день. Нашел где-то на просторах интернета... Выделить таблицу "Вспомогательная" и применить следующий макрос [vba]
Код
Sub Split_By_Rows() Dim cell As Range, n As Integer
Set cell = ActiveCell
For i = 1 To Selection.Rows.Count ar = Split(cell, Chr(10)) 'делим текст по переносам в массив n = UBound(ar) 'определяем кол-во фрагментов cell.Offset(1, 0).Resize(n, 1).EntireRow.Insert 'вставляем пустые строки ниже cell.Resize(n + 1, 1) = WorksheetFunction.Transpose(ar) 'вводим в них данные из массива Set cell = cell.Offset(n + 1, 0) 'сдвигаемся на следующую ячейку Next i End Sub
[/vba]
Добавлено: Хммм... Данный код уже есть в листе "Должно быть" Сразу не понял задачу...and_evg
Сообщение отредактировал and_evg - Вторник, 07.12.2021, 13:02
Слепил первое приближение процедуры, конвертирующей визуальные Alt+Enter в ячейке - в физические. Строчки "бьёт" по пробелам и по "минусам" (тире, переносам).
Вроде, работает. На оптимальность не претендую. Буду благодарен за придирчивое тестирование. Здоровая критика и конструктивные модификации также приветствуются.
Для тестовых запусков использовать процедуру test(). Весь код лучше поместить в обычный модуль (не модуль листа).
Сам VBA-код в это сообщение не влез, с предупреждением "Текст сообщения превышает допустимый лимит" (хотя, вроде, символов в запасе еще было предостаточно). Поэтому пытаюсь завернуть его в текстовый файл, а также попробую опубликовать код здесь в следующем сообщении.
Слепил первое приближение процедуры, конвертирующей визуальные Alt+Enter в ячейке - в физические. Строчки "бьёт" по пробелам и по "минусам" (тире, переносам).
Вроде, работает. На оптимальность не претендую. Буду благодарен за придирчивое тестирование. Здоровая критика и конструктивные модификации также приветствуются.
Для тестовых запусков использовать процедуру test(). Весь код лучше поместить в обычный модуль (не модуль листа).
Сам VBA-код в это сообщение не влез, с предупреждением "Текст сообщения превышает допустимый лимит" (хотя, вроде, символов в запасе еще было предостаточно). Поэтому пытаюсь завернуть его в текстовый файл, а также попробую опубликовать код здесь в следующем сообщении.Gustav
Sub test() Call convertVisualAltEnterToPhysical(Range("A4")) End Sub
Sub convertVisualAltEnterToPhysical(rng As Range)
Dim hgh0 As Double 'высота ячейки для пустой текстовой строки - при подстановке "" в Range.Value (единица высоты, "одна высота")
Dim str0 As String 'исходная строка - исходное значение Range.Value Dim str As String 'исходная строка после замены только очередного пробела/минуса на Alt+Enter Dim strNxt As String 'исходная строка после замены только следующего (очередного+1) пробела/минуса на Alt+Enter
Dim lines As Integer 'кол-во линий (строк) - для размещения исходной строки (текста) в ячейке (без Alt+Enter)
Dim start As Integer 'номер символа начала поиска очередного пробела/минуса Dim startNxt As Integer 'номер символа начала поиска следующего (очередного+1) пробела/минуса Dim posSpace As Integer 'позиция первого найденного ПРОБЕЛА при начале поиска от start Dim posMinus As Integer 'позиция первого найденного МИНУСА при начале поиска от start
Dim delimiters As Integer 'кол-во разделителей (пробелов/минусов) в исходной строке (максимальное потенциально возможное - для определения верхней границы цикла) Dim words As Integer 'кол-во слов = delimiters + 1 Dim strWords As String 'строка после замены минусов/пробелов на двойные тильды - заведомо длиннее исходной Dim lenWords As Integer 'заведомо большая длина этой строки (длина+1) Dim i As Integer 'счётчик цикла по delimiters
Dim arrLines() As Integer 'массив кол-в линий в ячейке, соответствующий "левым" текстам из arrLeft() Dim arrLeft() As String 'массив "левых" текстов = значений ячеек слева до очередного i-го пробела/минуса Dim arrRows() As String 'формируемый массив текстовых строк в ячейке
Dim prevRow As Integer Dim currRow As Integer Dim prevLeft As String Dim currLeft As String
str0 = rng.Value
strWords = Replace(Replace(str0, " ", "~~"), "-", "~~") lenWords = Len(strWords) + 1 'заведомо большая длина всей строки delimiters = UBound(Split(strWords, "~~")) words = delimiters + 1
ReDim arrLines(1 To words) ReDim arrLeft(1 To words)
'наполнение prevRow = lines + 1 For i = words To 1 Step -1 currRow = arrLines(i) If currRow <> prevRow Then arrRows(currRow) = arrLeft(i) End If prevRow = currRow Next i 'получение визуальных линий (строк) внутри ячейки For i = lines To 2 Step -1 arrRows(i) = LTrim(Replace(arrRows(i), arrRows(i - 1), "", 1, 1)) Next i
rng.Value = Join(arrRows, Chr(10)) End Sub
[/vba]
[vba]
Код
Sub test() Call convertVisualAltEnterToPhysical(Range("A4")) End Sub
Sub convertVisualAltEnterToPhysical(rng As Range)
Dim hgh0 As Double 'высота ячейки для пустой текстовой строки - при подстановке "" в Range.Value (единица высоты, "одна высота")
Dim str0 As String 'исходная строка - исходное значение Range.Value Dim str As String 'исходная строка после замены только очередного пробела/минуса на Alt+Enter Dim strNxt As String 'исходная строка после замены только следующего (очередного+1) пробела/минуса на Alt+Enter
Dim lines As Integer 'кол-во линий (строк) - для размещения исходной строки (текста) в ячейке (без Alt+Enter)
Dim start As Integer 'номер символа начала поиска очередного пробела/минуса Dim startNxt As Integer 'номер символа начала поиска следующего (очередного+1) пробела/минуса Dim posSpace As Integer 'позиция первого найденного ПРОБЕЛА при начале поиска от start Dim posMinus As Integer 'позиция первого найденного МИНУСА при начале поиска от start
Dim delimiters As Integer 'кол-во разделителей (пробелов/минусов) в исходной строке (максимальное потенциально возможное - для определения верхней границы цикла) Dim words As Integer 'кол-во слов = delimiters + 1 Dim strWords As String 'строка после замены минусов/пробелов на двойные тильды - заведомо длиннее исходной Dim lenWords As Integer 'заведомо большая длина этой строки (длина+1) Dim i As Integer 'счётчик цикла по delimiters
Dim arrLines() As Integer 'массив кол-в линий в ячейке, соответствующий "левым" текстам из arrLeft() Dim arrLeft() As String 'массив "левых" текстов = значений ячеек слева до очередного i-го пробела/минуса Dim arrRows() As String 'формируемый массив текстовых строк в ячейке
Dim prevRow As Integer Dim currRow As Integer Dim prevLeft As String Dim currLeft As String
str0 = rng.Value
strWords = Replace(Replace(str0, " ", "~~"), "-", "~~") lenWords = Len(strWords) + 1 'заведомо большая длина всей строки delimiters = UBound(Split(strWords, "~~")) words = delimiters + 1
ReDim arrLines(1 To words) ReDim arrLeft(1 To words)
'наполнение prevRow = lines + 1 For i = words To 1 Step -1 currRow = arrLines(i) If currRow <> prevRow Then arrRows(currRow) = arrLeft(i) End If prevRow = currRow Next i 'получение визуальных линий (строк) внутри ячейки For i = lines To 2 Step -1 arrRows(i) = LTrim(Replace(arrRows(i), arrRows(i - 1), "", 1, 1)) Next i