Макрос для объединения ячеек с нулями SOS!!!

[DJTreeno]

Доброго всем времени суток!
Помогите пожалуйста с макросом искал на сайте, но похожего не нашел.

У меня есть в столбце А в первой строке данные а в остальных нули, и соответственно это дело чередуется в самой верхней строке данные потом ниже скажем в 5-ти строках нули и т.д.

Наглядно где-то так:

Текст
0
0
0
0
Текст
0
0
Текст
0
0
0
0

Так вот текст нужно объединить с ячейками там, где нули и перейти к следующему тексту, а выйти из цикла по достижению пустой ячейки.

Заранее благодарен!!!

[vikttur]

Не оно? Заполнение пустых ячеек

[DJTreeno]

Должно быть что-то вроде этого, но не могу поменять условие, в этом коде объединяет ячейки с одинаковыми значениями:

Sub Объединение()
Dim RowIndex As Long
Dim StartRow As Long
Dim LastRow As Long
Dim ColumnToMerge As Long

StartRow = 1 ' с какой строки начинать
ColumnToMerge = 1 ' в какой колонке объединять

LastRow = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row

Application.DisplayAlerts = False

For RowIndex = StartRow + 1 To LastRow
With Cells(RowIndex, ColumnToMerge)
If .Value = .Offset(-1, 0).MergeArea.Cells(1).Value Then
Range(Cells(RowIndex, ColumnToMerge), .Offset(-1, 0)).Merge
End If
End With
Next RowIndex

Application.DisplayAlerts = True

End Sub

[EugeneS]

см. вложение, пример на колонке А

[DJTreeno]

Дополню для ясности, что в объединенной ячейке должен остаться только текст без добавления нулей.

[kuklp]

Sub Объединение()
    Dim RowIndex As Long
    Dim StartRow As Long
    Dim LastRow As Long
    Dim ColumnToMerge As Long

    StartRow = 1    ' с какой строки начинать
    ColumnToMerge = 1    ' в какой колонке объединять

    LastRow = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row

    Application.DisplayAlerts = False

    For RowIndex = StartRow + 1 To LastRow
        With Cells(RowIndex, ColumnToMerge)
            If .Value = .Offset(1, 0).MergeArea.Cells(1).Value Or .Value = 0 Then
                Range(Cells(RowIndex, ColumnToMerge), .Offset(-1, 0)).Merge
            End If
        End With
    Next RowIndex

    Application.DisplayAlerts = True

End Sub

[DJTreeno]

EugeneS, СПАСИБИЩЕ ОГРОМНОЕ!!! Выручили!!!

[EugeneS]

код, предложенный мною значительно проще и быстрее

[kuklp]

Не спорю, я исправил код автора:-)

[DJTreeno]

EugeneS, у вас очень простой код, а главное работает!!! Спасибо еще раз!!!

В ответ тоже хочу поделится, тоже простым кодом который копирует формулы из предыдущей строки при добавлении новой строки - тоже везде искал, но написал сам.

Sub Добавить_Строку()
'
' Добавление строки
'

'
lRow = Selection.Row
Range("Q" & Trim(Str(lRow))).Select
Selection.EntireRow.Insert
Range("Q" & Trim(Str(lRow - 1))).Select
Selection.Copy
Range("Q" & Trim(Str(lRow))).Select
ActiveSheet.Paste

Range("S" & Trim(Str(lRow - 1))).Select
Selection.Copy
Range("S" & Trim(Str(lRow))).Select
ActiveSheet.Paste

Range("U" & Trim(Str(lRow - 1))).Select
Selection.Copy
Range("U" & Trim(Str(lRow))).Select
ActiveSheet.Paste

Range("X" & Trim(Str(lRow - 1))).Select
Selection.Copy
Range("X" & Trim(Str(lRow))).Select
ActiveSheet.Paste

Application.CutCopyMode = False

End Sub