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

Вход

Регистрация

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

 

= Мир MS Excel/Разбитие текста ячеек на строки в диапазоне - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разбитие текста ячеек на строки в диапазоне (Макросы/Sub)
Разбитие текста ячеек на строки в диапазоне
CHEVRYACHOK Дата: Пятница, 04.11.2016, 09:38 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день и с праздником всех!
Если найдется минутка, посмотрите, пожалуйста, прикрепленный файлик.
Имеется макрос (не мой конечно), который разбивает текст одной ячейки на строки.
Я не знаю, что к нему дописать, чтобы он делал это по всем ячейкам диапазона.
Более подробное описание в прикрепленном файле и на Лист2 есть пример, как оно должно быть.
Заранее благодарен!
К сообщению приложен файл: 0370296.xls (58.0 Kb)
 
Ответить
СообщениеДобрый день и с праздником всех!
Если найдется минутка, посмотрите, пожалуйста, прикрепленный файлик.
Имеется макрос (не мой конечно), который разбивает текст одной ячейки на строки.
Я не знаю, что к нему дописать, чтобы он делал это по всем ячейкам диапазона.
Более подробное описание в прикрепленном файле и на Лист2 есть пример, как оно должно быть.
Заранее благодарен!

Автор - CHEVRYACHOK
Дата добавления - 04.11.2016 в 09:38
SLAVICK Дата: Пятница, 04.11.2016, 10:52 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
мм да а где Вы такой макрос нарыли?
Начал делать - пожалел что начал его исправлять - было бы проще новый написать :D .
Ну да ладно что-то получилось. - см. вложение.
Нужно выделить несколько ячеек, которые нужно разбить, и нажать кнопку.
К сообщению приложен файл: 0370296_2016-11.xls (62.0 Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщениемм да а где Вы такой макрос нарыли?
Начал делать - пожалел что начал его исправлять - было бы проще новый написать :D .
Ну да ладно что-то получилось. - см. вложение.
Нужно выделить несколько ячеек, которые нужно разбить, и нажать кнопку.

Автор - SLAVICK
Дата добавления - 04.11.2016 в 10:52
CHEVRYACHOK Дата: Пятница, 04.11.2016, 11:00 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
SLAVICK, на просторах этого форума и нарыл в одной из тем
если у вас есть другое решение, я не против )))
Чтобы он сработал по всем ячейкам мне нужно выделить весь диапазон столбца В
Я правильно понял?
 
Ответить
СообщениеSLAVICK, на просторах этого форума и нарыл в одной из тем
если у вас есть другое решение, я не против )))
Чтобы он сработал по всем ячейкам мне нужно выделить весь диапазон столбца В
Я правильно понял?

Автор - CHEVRYACHOK
Дата добавления - 04.11.2016 в 11:00
SLAVICK Дата: Пятница, 04.11.2016, 11:51 | Сообщение № 4
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
Я правильно понял?

А попробовать боитесь? - он вас не укусит. :) . Тем более что я уже писал:
Нужно выделить несколько ячеек, которые нужно разбить, и нажать кнопку.


у вас есть другое решение,

где - то в закромах есть - лень искать вроде и так уже работает.
ЗЫ а Вы эту тему до конца просмотрели?


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
Я правильно понял?

А попробовать боитесь? - он вас не укусит. :) . Тем более что я уже писал:
Нужно выделить несколько ячеек, которые нужно разбить, и нажать кнопку.


у вас есть другое решение,

где - то в закромах есть - лень искать вроде и так уже работает.
ЗЫ а Вы эту тему до конца просмотрели?

Автор - SLAVICK
Дата добавления - 04.11.2016 в 11:51
CHEVRYACHOK Дата: Пятница, 04.11.2016, 12:18 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
SLAVICK, спасибо!
В этой теме как раз и взял макрос )
 
Ответить
СообщениеSLAVICK, спасибо!
В этой теме как раз и взял макрос )

Автор - CHEVRYACHOK
Дата добавления - 04.11.2016 в 12:18
Wasilich Дата: Пятница, 04.11.2016, 13:47 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
было бы проще новый написать
Да уж, чужая душа - потемки. :D
Моя так сообразила. :)
[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]
 
Ответить
Сообщение
было бы проще новый написать
Да уж, чужая душа - потемки. :D
Моя так сообразила. :)
[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]

Автор - Wasilich
Дата добавления - 04.11.2016 в 13:47
CHEVRYACHOK Дата: Пятница, 04.11.2016, 14:19 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Wasilich, спасибо, работает!
Но мне нужно выполнять перенос на том же листе
и при (DNS = 42 'длина новой строки) делает строки до 56 символов
 
Ответить
СообщениеWasilich, спасибо, работает!
Но мне нужно выполнять перенос на том же листе
и при (DNS = 42 'длина новой строки) делает строки до 56 символов

Автор - CHEVRYACHOK
Дата добавления - 04.11.2016 в 14:19
Wasilich Дата: Пятница, 04.11.2016, 14:52 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
Но мне нужно выполнять перенос на том же листе
Я же делал в соответствии с примером. А на том же, это где?
(DNS = 42 'длина новой строки) делает строки до 56 символов
Ну да, если в длину строки из 42-х символов попадает первая букву следующего длинного слова то это слово целиком добавляется к строке. Варьируйте, подбирайте. Поставьте 40.
 
Ответить
Сообщение
Но мне нужно выполнять перенос на том же листе
Я же делал в соответствии с примером. А на том же, это где?
(DNS = 42 'длина новой строки) делает строки до 56 символов
Ну да, если в длину строки из 42-х символов попадает первая букву следующего длинного слова то это слово целиком добавляется к строке. Варьируйте, подбирайте. Поставьте 40.

Автор - Wasilich
Дата добавления - 04.11.2016 в 14:52
CHEVRYACHOK Дата: Пятница, 04.11.2016, 15:07 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Wasilich, чтобы все происходило на листе Раздел 3.
С длиной понял, спасибо!
 
Ответить
СообщениеWasilich, чтобы все происходило на листе Раздел 3.
С длиной понял, спасибо!

Автор - CHEVRYACHOK
Дата добавления - 04.11.2016 в 15:07
Wasilich Дата: Пятница, 04.11.2016, 15:12 | Сообщение № 10
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
чтобы все происходило на листе Раздел 3.
Это понятно, а конкретно строки, колонки.
Все, меня ждут. буду поздно. мож кто другой подскажет


Сообщение отредактировал Wasilich - Пятница, 04.11.2016, 15:13
 
Ответить
Сообщение
чтобы все происходило на листе Раздел 3.
Это понятно, а конкретно строки, колонки.
Все, меня ждут. буду поздно. мож кто другой подскажет

Автор - Wasilich
Дата добавления - 04.11.2016 в 15:12
CHEVRYACHOK Дата: Пятница, 04.11.2016, 16:43 | Сообщение № 11
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Wasilich, спасибо за помощь, вариант SLAVIKa подошел
 
Ответить
СообщениеWasilich, спасибо за помощь, вариант SLAVIKa подошел

Автор - CHEVRYACHOK
Дата добавления - 04.11.2016 в 16:43
nilem Дата: Пятница, 04.11.2016, 18:02 | Сообщение № 12
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
Просто как вариант, используем Justify
[vba]
Код
Sub ertert()
Dim x, i&, j&
With Application
    .ScreenUpdating = False: .DisplayAlerts = False
End With

With Range("A4").CurrentRegion
    x = .Offset(1).Resize(.Rows.Count - 1).Value
    .Offset(1).ClearContents
End With

For i = 1 To UBound(x)
    j = WorksheetFunction.Max(Cells(Rows.Count, 1).End(xlUp)(2, 1).Row, _
                    Cells(Rows.Count, 2).End(xlUp)(2, 1).Row)
    Cells(j, 2)(1, 0).Resize(, 2).Value = Array(x(i, 1), x(i, 2))
    Cells(j, 2).Justify
Next i

With Application
    .ScreenUpdating = True: .DisplayAlerts = True
End With
End Sub
[/vba]


Яндекс.Деньги 4100159601573
 
Ответить
СообщениеПросто как вариант, используем Justify
[vba]
Код
Sub ertert()
Dim x, i&, j&
With Application
    .ScreenUpdating = False: .DisplayAlerts = False
End With

With Range("A4").CurrentRegion
    x = .Offset(1).Resize(.Rows.Count - 1).Value
    .Offset(1).ClearContents
End With

For i = 1 To UBound(x)
    j = WorksheetFunction.Max(Cells(Rows.Count, 1).End(xlUp)(2, 1).Row, _
                    Cells(Rows.Count, 2).End(xlUp)(2, 1).Row)
    Cells(j, 2)(1, 0).Resize(, 2).Value = Array(x(i, 1), x(i, 2))
    Cells(j, 2).Justify
Next i

With Application
    .ScreenUpdating = True: .DisplayAlerts = True
End With
End Sub
[/vba]

Автор - nilem
Дата добавления - 04.11.2016 в 18:02
Gustav Дата: Пятница, 04.11.2016, 20:26 | Сообщение № 13
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2697
Репутация: 1123 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
как вариант, используем 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 вручную можно выполнить так: Вкладка "Главная" => блок "Редактирование" => Заполнить => Выровнять.


МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Пятница, 04.11.2016, 23:20
 
Ответить
Сообщение
как вариант, используем 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
Дата добавления - 04.11.2016 в 20:26
Wasilich Дата: Пятница, 04.11.2016, 22:11 | Сообщение № 14
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
Вернулся. Ого! Офигеть. Вообще не врубаюсь.
А чё надо то было? Требую пояснений!!!
Или это уже завтра, на трезвую. :D :D :D
 
Ответить
СообщениеВернулся. Ого! Офигеть. Вообще не врубаюсь.
А чё надо то было? Требую пояснений!!!
Или это уже завтра, на трезвую. :D :D :D

Автор - Wasilich
Дата добавления - 04.11.2016 в 22:11
CHEVRYACHOK Дата: Суббота, 05.11.2016, 07:17 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
nilem, Gustav, hands
Все прекрасно работает!
Огромное Вам спасибо!
 
Ответить
Сообщениеnilem, Gustav, hands
Все прекрасно работает!
Огромное Вам спасибо!

Автор - CHEVRYACHOK
Дата добавления - 05.11.2016 в 07:17
Wasilich Дата: Суббота, 05.11.2016, 10:32 | Сообщение № 16
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
Теперь понятно как надо было! Хотя уже и не нужно, однако свой вариант подправлю.
Вдруг кому то пригодится.
Дописываем в конец исходного диапазона, а после исходный удаляем.
[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
[/vba]

Автор - Wasilich
Дата добавления - 05.11.2016 в 10:32
CHEVRYACHOK Дата: Суббота, 05.11.2016, 12:37 | Сообщение № 17
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Wasilich, да, теперь работает ))) Спасибо!
 
Ответить
СообщениеWasilich, да, теперь работает ))) Спасибо!

Автор - CHEVRYACHOK
Дата добавления - 05.11.2016 в 12:37
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разбитие текста ячеек на строки в диапазоне (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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