Добрый день и с праздником всех! Если найдется минутка, посмотрите, пожалуйста, прикрепленный файлик. Имеется макрос (не мой конечно), который разбивает текст одной ячейки на строки. Я не знаю, что к нему дописать, чтобы он делал это по всем ячейкам диапазона. Более подробное описание в прикрепленном файле и на Лист2 есть пример, как оно должно быть. Заранее благодарен!
Добрый день и с праздником всех! Если найдется минутка, посмотрите, пожалуйста, прикрепленный файлик. Имеется макрос (не мой конечно), который разбивает текст одной ячейки на строки. Я не знаю, что к нему дописать, чтобы он делал это по всем ячейкам диапазона. Более подробное описание в прикрепленном файле и на Лист2 есть пример, как оно должно быть. Заранее благодарен!CHEVRYACHOK
мм да а где Вы такой макрос нарыли? Начал делать - пожалел что начал его исправлять - было бы проще новый написать . Ну да ладно что-то получилось. - см. вложение. Нужно выделить несколько ячеек, которые нужно разбить, и нажать кнопку.
мм да а где Вы такой макрос нарыли? Начал делать - пожалел что начал его исправлять - было бы проще новый написать . Ну да ладно что-то получилось. - см. вложение. Нужно выделить несколько ячеек, которые нужно разбить, и нажать кнопку.SLAVICK
SLAVICK, на просторах этого форума и нарыл в одной из тем если у вас есть другое решение, я не против ))) Чтобы он сработал по всем ячейкам мне нужно выделить весь диапазон столбца В Я правильно понял?
SLAVICK, на просторах этого форума и нарыл в одной из тем если у вас есть другое решение, я не против ))) Чтобы он сработал по всем ячейкам мне нужно выделить весь диапазон столбца В Я правильно понял?CHEVRYACHOK
Да уж, чужая душа - потемки. Моя так сообразила. [vba]
Код
Sub ТПС() Dim DNS&, s&, i&, NStr$, sText, x Sheets("Лист2").Range("A5:b100").ClearContents DNS = 42 'длина новой строки s = 5 For i = 5 To Range("B" & Rows.Count).End(xlUp).Row sText = Cells(i, 2) sText = Application.Trim(sText) 'сжать пробелы If sText <> "" Then sText = Split(sText, " ") NStr = "" 'новая строка Sheets("Лист2").Cells(s, 1) = Cells(i, 1) For x = LBound(sText) To UBound(sText) If sText(x) <> "" Then NStr = NStr & sText(x) & " " If Len(NStr) > DNS Or x = UBound(sText) Then 'MsgBox NStr & " " & Len(NStr) Sheets("Лист2").Cells(s, 2) = NStr NStr = "" s = s + 1 End If End If Next x Else If Cells(i, 1) > 0 Then Sheets("Лист2").Cells(s, 1) = Cells(i, 1) s = s + 1 End If End If Next i Sheets("Лист2").Select End Sub
Да уж, чужая душа - потемки. Моя так сообразила. [vba]
Код
Sub ТПС() Dim DNS&, s&, i&, NStr$, sText, x Sheets("Лист2").Range("A5:b100").ClearContents DNS = 42 'длина новой строки s = 5 For i = 5 To Range("B" & Rows.Count).End(xlUp).Row sText = Cells(i, 2) sText = Application.Trim(sText) 'сжать пробелы If sText <> "" Then sText = Split(sText, " ") NStr = "" 'новая строка Sheets("Лист2").Cells(s, 1) = Cells(i, 1) For x = LBound(sText) To UBound(sText) If sText(x) <> "" Then NStr = NStr & sText(x) & " " If Len(NStr) > DNS Or x = UBound(sText) Then 'MsgBox NStr & " " & Len(NStr) Sheets("Лист2").Cells(s, 2) = NStr NStr = "" s = s + 1 End If End If Next x Else If Cells(i, 1) > 0 Then Sheets("Лист2").Cells(s, 1) = Cells(i, 1) s = s + 1 End If End If Next i Sheets("Лист2").Select End Sub
Wasilich, спасибо, работает! Но мне нужно выполнять перенос на том же листе и при (DNS = 42 'длина новой строки) делает строки до 56 символов
Wasilich, спасибо, работает! Но мне нужно выполнять перенос на том же листе и при (DNS = 42 'длина новой строки) делает строки до 56 символовCHEVRYACHOK
(DNS = 42 'длина новой строки) делает строки до 56 символов
Ну да, если в длину строки из 42-х символов попадает первая букву следующего длинного слова то это слово целиком добавляется к строке. Варьируйте, подбирайте. Поставьте 40.
(DNS = 42 'длина новой строки) делает строки до 56 символов
Ну да, если в длину строки из 42-х символов попадает первая букву следующего длинного слова то это слово целиком добавляется к строке. Варьируйте, подбирайте. Поставьте 40.Wasilich
Хорошая тема. Тоже хотел опубликовать компактное решение с ним. Да спохватился, когда стал тестировать - распределяет (гад!) только первые 255 символов ячейки, остальные обрезает...
P.S. Ну, вроде, победил. Представляю свой алгоритм с Justify без ограничения в 255 символов. [vba]
Код
Sub runMe() 'запускаем эту программу Dim rng As Range, rngAll As Range Dim i As Integer Dim val As String, rest As String
Set rngAll = Selection 'перед выполнением выделить одноколоночный диапазон, например, в колонке B
For i = rngAll.Cells.Count To 1 Step -1 'идём снизу в верх! Set rng = rngAll.Cells(i) rest = "" Do 'применяем Justify пока после очередного не останется нераспределенного текста val = rng.Value & rest rng.Value = val justCurrCell rng 'здесь Justify внутри rest = Mid(val, 256) Loop Until rest = "" Next i End Sub
Sub justCurrCell(rng As Range) 'подпрограмма обработки текущей ячейки Dim rngLast As Range rng.Offset(1).Resize(1 + 1000).EntireRow.Insert 'временно вставляем 1000 строк (можно разумно изменить) rng.Resize(2 + 1000).Justify If IsEmpty(rng.Offset(1)) Then 'запоминаем последнюю ячейку - может потребоваться для дополнительного Justify Set rngLast = rng Else Set rngLast = rng.End(xlDown) End If rng.Offset(1).Resize(1 + 1000).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'удаляем лишние пустые строки Set rng = rngLast 'возвращаем последнюю ячейку в вызывающую процедуру End Sub
[/vba]
P.P.S. По меню на Ленте команду Justify вручную можно выполнить так: Вкладка "Главная" => блок "Редактирование" => Заполнить => Выровнять.
Хорошая тема. Тоже хотел опубликовать компактное решение с ним. Да спохватился, когда стал тестировать - распределяет (гад!) только первые 255 символов ячейки, остальные обрезает...
P.S. Ну, вроде, победил. Представляю свой алгоритм с Justify без ограничения в 255 символов. [vba]
Код
Sub runMe() 'запускаем эту программу Dim rng As Range, rngAll As Range Dim i As Integer Dim val As String, rest As String
Set rngAll = Selection 'перед выполнением выделить одноколоночный диапазон, например, в колонке B
For i = rngAll.Cells.Count To 1 Step -1 'идём снизу в верх! Set rng = rngAll.Cells(i) rest = "" Do 'применяем Justify пока после очередного не останется нераспределенного текста val = rng.Value & rest rng.Value = val justCurrCell rng 'здесь Justify внутри rest = Mid(val, 256) Loop Until rest = "" Next i End Sub
Sub justCurrCell(rng As Range) 'подпрограмма обработки текущей ячейки Dim rngLast As Range rng.Offset(1).Resize(1 + 1000).EntireRow.Insert 'временно вставляем 1000 строк (можно разумно изменить) rng.Resize(2 + 1000).Justify If IsEmpty(rng.Offset(1)) Then 'запоминаем последнюю ячейку - может потребоваться для дополнительного Justify Set rngLast = rng Else Set rngLast = rng.End(xlDown) End If rng.Offset(1).Resize(1 + 1000).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'удаляем лишние пустые строки Set rng = rngLast 'возвращаем последнюю ячейку в вызывающую процедуру End Sub
[/vba]
P.P.S. По меню на Ленте команду Justify вручную можно выполнить так: Вкладка "Главная" => блок "Редактирование" => Заполнить => Выровнять.Gustav
Теперь понятно как надо было! Хотя уже и не нужно, однако свой вариант подправлю. Вдруг кому то пригодится. Дописываем в конец исходного диапазона, а после исходный удаляем. [vba]
Код
Sub ТПС2() Dim PS&, DNS&, s&, i&, NStr$, sText, x Application.ScreenUpdating = False PS = Range("A" & Rows.Count).End(xlUp).Row s = PS + 1 Range("A" & s & ":B2000").ClearContents DNS = 42 'длина новой строки For i = 5 To PS sText = Cells(i, 2) sText = Application.Trim(sText) 'сжать пробелы If sText <> "" Then sText = Split(sText, " ") NStr = "" 'новая строка Cells(s, 1) = Cells(i, 1) For x = LBound(sText) To UBound(sText) If sText(x) <> "" Then NStr = NStr & sText(x) & " " If Len(NStr) > DNS Or x = UBound(sText) Then 'MsgBox NStr & " " & Len(NStr) Cells(s, 2) = NStr NStr = "" s = s + 1 End If End If Next x Else If Cells(i, 1) > 0 Then Cells(s, 1) = Cells(i, 1) s = s + 1 End If End If Next i Rows("5:" & PS).Delete Application.ScreenUpdating = True End Sub
[/vba]
Теперь понятно как надо было! Хотя уже и не нужно, однако свой вариант подправлю. Вдруг кому то пригодится. Дописываем в конец исходного диапазона, а после исходный удаляем. [vba]
Код
Sub ТПС2() Dim PS&, DNS&, s&, i&, NStr$, sText, x Application.ScreenUpdating = False PS = Range("A" & Rows.Count).End(xlUp).Row s = PS + 1 Range("A" & s & ":B2000").ClearContents DNS = 42 'длина новой строки For i = 5 To PS sText = Cells(i, 2) sText = Application.Trim(sText) 'сжать пробелы If sText <> "" Then sText = Split(sText, " ") NStr = "" 'новая строка Cells(s, 1) = Cells(i, 1) For x = LBound(sText) To UBound(sText) If sText(x) <> "" Then NStr = NStr & sText(x) & " " If Len(NStr) > DNS Or x = UBound(sText) Then 'MsgBox NStr & " " & Len(NStr) Cells(s, 2) = NStr NStr = "" s = s + 1 End If End If Next x Else If Cells(i, 1) > 0 Then Cells(s, 1) = Cells(i, 1) s = s + 1 End If End If Next i Rows("5:" & PS).Delete Application.ScreenUpdating = True End Sub