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

Question

Я хочу объединить несколько заполненных строк, пока не найдем пустую строку / ячейку. Я думаю, что вы должны увидеть картинку, чтобы понять мою проблему.

Answer 1

Вот еще один метод, который должен быть быстрее, чем цикл по всем строкам.

Прежде всего это звезда в конце листа и петли назад. Этот метод использует метод .End(xlUp) для перехода по пустым строкам к следующим данным, а затем использует .CurrentRegion, чтобы найти все данные до следующей пустой ячейки, чтобы затем присоединиться к ней.

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

Option Explicit

Public Sub MergeConinousCells()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim RangeToJoin As Range
    Set RangeToJoin = ws.Cells(ws.Rows.Count, "A") 'initialize with very last cell

    Do Until RangeToJoin.Row <= 1 'loop until we reach the first row
        Set RangeToJoin = RangeToJoin.Offset(RowOffset:=-1).Resize(RowSize:=1).End(xlUp).CurrentRegion.Resize(ColumnSize:=1)
        If RangeToJoin.Rows.Count > 1 Then 'if more than one cell in this area then join them
            ws.Cells(RangeToJoin.Row, "C").Value = Join(WorksheetFunction.Transpose(RangeToJoin), ";")
        Else 'only one cell so transfer value only
            ws.Cells(RangeToJoin.Row, "C").Value = RangeToJoin.Value
        End If
    Loop
End Sub

Answer 2

На основании вашего изображения должно работать что-то подобное ...

Option Explicit
Sub merge()

Dim arr() As Variant
Dim i As Long
Dim a As Integer
Dim ColALastRow As Long
Dim FRow As Long

ColALastRow = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
FRow = 0
a = 0

For i = 1 To ColALastRow

Do While ThisWorkbook.Sheets("Sheet1").Cells(i, 1) <> vbNullString
ReDim Preserve arr(0 To a) As Variant
FRow = FRow + 1
arr(a) = ThisWorkbook.Sheets("Sheet1").Cells(i, 1)
i = i + 1
a = a + 1
Loop

If Len(Join(arr, "")) <> 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i - FRow, 2) = Join(arr, ";")
FRow = 0
a = 0
Erase arr
End If

Next

End Sub