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

Вход

Регистрация

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

 

= Мир MS Excel/Перенос текста по строкам VBA - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос текста по строкам VBA (Макросы/Sub)
Перенос текста по строкам VBA
4step Дата: Вторник, 07.12.2021, 04:52 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 20% ±

Добрый день! Прошу от Вас помощи в выполнении определённой задачи, а именно необходимо текст разбить по строкам:
1. Формируется определенная ширина текста с использованием команды "Перенести текст";
2. Сформированный текст преобразуется "как-то" с простановкой [ALT]+[ENTER] (т.е. визуальное преобразуется в физическое);
3. И сформированный текст дробится по строкам с помощью макроса (код в файле) .
Вопрос, можно ли как-то системно выполнить пункт 2 и привязать к существующему макросу?
К сообщению приложен файл: 4877691.xlsm(19.7 Kb)


Сообщение отредактировал 4step - Вторник, 07.12.2021, 08:09
 
Ответить
СообщениеДобрый день! Прошу от Вас помощи в выполнении определённой задачи, а именно необходимо текст разбить по строкам:
1. Формируется определенная ширина текста с использованием команды "Перенести текст";
2. Сформированный текст преобразуется "как-то" с простановкой [ALT]+[ENTER] (т.е. визуальное преобразуется в физическое);
3. И сформированный текст дробится по строкам с помощью макроса (код в файле) .
Вопрос, можно ли как-то системно выполнить пункт 2 и привязать к существующему макросу?

Автор - 4step
Дата добавления - 07.12.2021 в 04:52
and_evg Дата: Вторник, 07.12.2021, 12:59 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 409
Репутация: 71 ±
Замечаний: 0% ±

Excel 2007
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 - Вторник, 07.12.2021, 13:02
 
Ответить
Сообщение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
Дата добавления - 07.12.2021 в 12:59
4step Дата: Вторник, 07.12.2021, 13:18 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 20% ±

Да, он прикреплен к 3-му листу и выполняет с применением [alt]+[enter].
А вопрос был поставлен, в последовательности действий с 1-го шага.
 
Ответить
СообщениеДа, он прикреплен к 3-му листу и выполняет с применением [alt]+[enter].
А вопрос был поставлен, в последовательности действий с 1-го шага.

Автор - 4step
Дата добавления - 07.12.2021 в 13:18
Gustav Дата: Вторник, 07.12.2021, 22:43 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 2141
Репутация: 841 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Слепил первое приближение процедуры, конвертирующей визуальные Alt+Enter в ячейке - в физические. Строчки "бьёт" по пробелам и по "минусам" (тире, переносам).

Вроде, работает. На оптимальность не претендую. Буду благодарен за придирчивое тестирование. Здоровая критика и конструктивные модификации также приветствуются.

Для тестовых запусков использовать процедуру test(). Весь код лучше поместить в обычный модуль (не модуль листа).

Сам VBA-код в это сообщение не влез, с предупреждением "Текст сообщения превышает допустимый лимит" (хотя, вроде, символов в запасе еще было предостаточно). Поэтому пытаюсь завернуть его в текстовый файл, а также попробую опубликовать код здесь в следующем сообщении.


Мой tip box - яд 41001663842605
 
Ответить
СообщениеСлепил первое приближение процедуры, конвертирующей визуальные Alt+Enter в ячейке - в физические. Строчки "бьёт" по пробелам и по "минусам" (тире, переносам).

Вроде, работает. На оптимальность не претендую. Буду благодарен за придирчивое тестирование. Здоровая критика и конструктивные модификации также приветствуются.

Для тестовых запусков использовать процедуру test(). Весь код лучше поместить в обычный модуль (не модуль листа).

Сам VBA-код в это сообщение не влез, с предупреждением "Текст сообщения превышает допустимый лимит" (хотя, вроде, символов в запасе еще было предостаточно). Поэтому пытаюсь завернуть его в текстовый файл, а также попробую опубликовать код здесь в следующем сообщении.

Автор - Gustav
Дата добавления - 07.12.2021 в 22:43
Gustav Дата: Вторник, 07.12.2021, 22:46 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 2141
Репутация: 841 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
[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)
    
    rng.Value = ""
    hgh0 = rng.Height '"одна высота" строки = высота ячейки при пустой строке
    rng.Value = str0
    lines = Int(rng.Height / hgh0 + 0.5)
    
    ReDim arrRows(1 To lines)
    
    start = 1
    
    For i = 1 To words
    
        'поиск места очередного разделителя
        posSpace = InStr(start, str0, " ")
        If posSpace = 0 Then posSpace = lenWords
        
        posMinus = InStr(start, str0, "-")
        If posMinus = 0 Then posMinus = lenWords
               
        If posSpace < posMinus Then
            startNxt = posSpace + 1
            
        ElseIf posMinus < posSpace Then
            startNxt = posMinus + 2 'потому что вместо одного символа вставляется два
            
        Else
            'posSpace = posMinus = lenWords
            startNxt = lenWords
        End If
        
       
        str = Left(str0, startNxt - 2)
        rng.Value = str
        arrLines(i) = Int(rng.Height / hgh0 + 0.5)
        arrLeft(i) = str
        
        start = startNxt
    Next i
    
    'наполнение
    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]


Мой tip box - яд 41001663842605

Сообщение отредактировал Gustav - Среда, 08.12.2021, 01:20
 
Ответить
Сообщение[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)
    
    rng.Value = ""
    hgh0 = rng.Height '"одна высота" строки = высота ячейки при пустой строке
    rng.Value = str0
    lines = Int(rng.Height / hgh0 + 0.5)
    
    ReDim arrRows(1 To lines)
    
    start = 1
    
    For i = 1 To words
    
        'поиск места очередного разделителя
        posSpace = InStr(start, str0, " ")
        If posSpace = 0 Then posSpace = lenWords
        
        posMinus = InStr(start, str0, "-")
        If posMinus = 0 Then posMinus = lenWords
               
        If posSpace < posMinus Then
            startNxt = posSpace + 1
            
        ElseIf posMinus < posSpace Then
            startNxt = posMinus + 2 'потому что вместо одного символа вставляется два
            
        Else
            'posSpace = posMinus = lenWords
            startNxt = lenWords
        End If
        
       
        str = Left(str0, startNxt - 2)
        rng.Value = str
        arrLines(i) = Int(rng.Height / hgh0 + 0.5)
        arrLeft(i) = str
        
        start = startNxt
    Next i
    
    'наполнение
    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]

Автор - Gustav
Дата добавления - 07.12.2021 в 22:46
4step Дата: Среда, 08.12.2021, 03:46 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 56
Репутация: 0 ±
Замечаний: 20% ±

Для тестовых запусков

Действие кода вроде работает на ячейке "А4". А возможно ли использовать действие по всему столбцу "А:А"?
 
Ответить
Сообщение
Для тестовых запусков

Действие кода вроде работает на ячейке "А4". А возможно ли использовать действие по всему столбцу "А:А"?

Автор - 4step
Дата добавления - 08.12.2021 в 03:46
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос текста по строкам VBA (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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