如何合并填充的行，直到反复找到空白单元格

Question

我要合并多个填充行，直到找到空白行/单元格。我想您必须看图片才能理解我的问题。

Answer 1

根据您的图片，类似的东西应该可以工作...

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

Answer 2

这是另一种比遍历所有行更快的技术。

首先，此操作在页面末尾开始并向后循环。 此技术使用.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