Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Разделить текст по разделителю и вывести в столбик vba
 
#1
10.10.2022 14:30:50
Здравствуйте! Помогите, пожалуйста, решить проблему. Есть текст в ячейке: ФИО людей через запятую. Нужно разделить их на отдельные строки. Пока решаю текстом по столбцам и потом копировать с транспонированием. Но это довольно долго, а делать так приходится часто. Есть ли макрос на этот случай?
 
 
 
#2
10.10.2022 14:41:09
Код
Sub РазделитьИдобавить()
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    Dim arr As Variant
    Dim cl As Range
    For Each cl In rr
        If Not IsEmpty(cl.Value) Then
            arr = Split(cl.Value, ",")
            If LBound(arr) <> UBound(arr) Then
                cl.Cells(2, 1).Resize(UBound(arr) - LBound(arr)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                cl.Resize(UBound(arr) - LBound(arr) + 1) = Application.Transpose(arr)
            End If
        End If
    Next
End Sub
 
 
 
#3
10.10.2022 14:42:51
Galina7138, добрый день!
Еще вариант:
   - выбираете диапазон с данными для транспонирования и ячейку для выгрузки
Код
Sub split_()
    Dim arr, text(), target_range As Range
    Dim i, j, t, tmp
    arr = Application.InputBox("Выберите диапазон для транспонирования", Type:=8): t = 1
    Set target_range = Application.InputBox("Выберите ячейку для выгрузки результата", Type:=8)
    
    For Each i In arr
        tmp = Split(i, ", ")
        For Each j In tmp
            ReDim Preserve text(1 To t)
            text(t) = j
            t = t + 1
        Next j
    Next i
    target_range.Resize(UBound(text), 1) = Application.Transpose(text)
End Sub
 
 
 
#4
10.10.2022 15:21:06
Без цикла. Для одного столбца. Предварительно выделить данные
Код
Sub tt()
    Application.ScreenUpdating = 0
    With Selection
        .Replace What:=", ", Replacement:=","
        .Replace What:=" ", Replacement:="!"
        .Replace What:=",", Replacement:=" "
        nc_ = .ColumnWidth
        .ColumnWidth = 1
        Application.DisplayAlerts = 0
        .Justify
        Application.DisplayAlerts = 1
        .ColumnWidth = nc_
        Range(.Range("A1"), .End(xlDown)).Replace What:="!", Replacement:=" "
    End With
    Application.ScreenUpdating = 1
End Sub
Скажи мне, кудесник, любимец ба’гов...
 
 
 
#5
11.10.2022 14:45:16
Без VBA
Деление слипшегося текста функцией ФИЛЬТР.XML
Изменено: Msi2102 - 11.10.2022 14:45:46
 
 
 
Страницы: 1
Наверх