Страницы: 1
RSS
Нужно объединять ячейки с сохранением текста
 
Всем здравствуйте!
Нужно объединять ячейки с сохранением текста. Строк около 5000.
Нашел пример как объединять, но не могу понять как прописать цикл.... подскажите пожалуйста.
Нужно объединять ячейки в строке в диапазоне A1:E1, и так до A5000:E5000. Причем нужно чтобы при установленном фильтре объединялись только видимые ячейки. Невидимые не нужно объединять.
Макрос нашел в примерах, но не могу с циклом разобраться...
Думаю там всё просто должно быть, но как именно - понять не могу, туплю уже часа 3 над этим)
Пример прилагаю. Помогите плз.
Изменено: Yuriy575 - 04.04.2020 14:58:04
 
как-то так
Код
Sub MergeToOneCell()
    Dim rCell As Range
    Range(Cells(1, 1), Cells([A1000000].End(xlUp).Row, 1)).SpecialCells(xlCellTypeVisible).Select
    Application.DisplayAlerts = False   'отключаем стандартное предупреждение о потере текста
    
    For Each rCell In Selection.Cells
        sMergeStr = txt(rCell)
        rCell.Resize(1, 5).Merge Across:=False               'объединяем ячейки
        rCell = sMergeStr    'добавляем к объед.ячейке суммарный текст
    Next rCell
    
    Application.DisplayAlerts = True
End Sub

Function txt(r As Range)
    arr = r.Resize(1, 5)
    txt = arr(1, 1)
    For i = 2 To UBound(arr, 2)
        txt = txt & " " & arr(1, i)
    Next
End Function
Изменено: buchlotnik - 04.04.2020 15:12:05
Соблюдение правил форума не освобождает от модераторского произвола
 
Еще вариант.
Код
Sub MergeToOneCell()
    Const sDELIM As String = " "     'символ-разделитель
    Dim rCell As Range
    Dim sMergeStr As String
    Application.DisplayAlerts = False
    For Each rw In ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows
        rww = rw.Row
        If rww > 1 Then
            sMergeStr = ""
            For i = 1 To 5
                sMergeStr = sMergeStr & sDELIM & Cells(rww, i).Text 'собираем текст из ячеек
            Next
            Cells(rww, 1).Resize(, 5).Merge
            Cells(rww, 1) = LTrim(sMergeStr)
        End If
    Next
    Application.DisplayAlerts = True
End Sub
 
skais675, Применил этот вариант, работает.
А как сделать чтоб по строкам объединялись смежные ячейки столбцов Fи G? При этом чтоб в них закидывался текст из диапазонов F:M ?
Что нужно поменять в коде?
 
Код
Sub MergeToOneCell222()
    Const sDELIM As String = " "     'символ-разделитель
    Dim rCell As Range
    Dim sMergeStr As String
    Application.DisplayAlerts = False
    For Each rw In ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows
        rww = rw.Row
        If rww > 1 Then
            sMergeStr = ""
            For i = 1 To 5
                sMergeStr = sMergeStr & sDELIM & Cells(rww, i).Text 'собираем текст из ячеек
            Next
            Cells(rww, 1).Resize(, 5).Merge
            Cells(rww, 1) = LTrim(sMergeStr)
            s2 = ""
            For i = 6 To 13
                s2 = s2 & sDELIM & Cells(rww, i).Text 'собираем текст из ячеек
            Next
            Cells(rww, 6).Resize(, 2).Merge
            Cells(rww, 6) = s2
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Изменено: skais675 - 04.04.2020 19:08:14
 
skais675, проверил, что-то не работает
Приложил пример, как должно получиться.
Изменено: Yuriy575 - 04.04.2020 18:22:36
 
Yuriy575, поправил в #5 сообщении.
 
skais675, применил этот код, всё как надо работает теперь :)
Спасибо большое)
Но немного не понял как работает, почему в этой строке
Код
Cells(rww, 1).Resize(, 5).Merge

не указано число перед запятой... Попробую разобраться на выходных.

 
Цитата
Yuriy575 написал:
не указано число перед запятой
Это означает, что для первого аргумента используется значение по умолчанию.
В данном случае это означает, что изменение размера по строкам не происходит.
 
МатросНаЗебре, да) спасибо)) изучил свойство Resize и догнал вроде)) Пошел изучать VBA дальше))
Страницы: 1
Наверх