Concatenate a large amount of cells - run faster

Question

I have a VBA that takes all the rows with the same ID in Column 1 and concatenates the data in Column 3 to a single cell with line breaks. The code works, but takes 10+ seconds to run. I have about 3-4k rows of data but I was hoping this could run much faster.

Sub merge()
Dim lngRow As Integer

    With ActiveSheet
        Dim columnToMatch As Integer: columnToMatch = 1
        Dim columnToConcatenate As Integer: columnToConcatenate = 3 'determie which column has the values to merge


        lngRow = .Cells(65536, columnToMatch).End(xlUp).Row
        .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes

        Do
            If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then
                .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow - 1, columnToConcatenate) & vbNewLine & .Cells(lngRow, columnToConcatenate)
                .Rows(lngRow).Delete
            End If

            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With
End Sub

I have tried removing the active sheet reference and turning off events/screen updating. There are no calculations on the sheet. I have also tried sorting the data first.

Any ideas how I can improve efficiency and speed?

Answer 1

Merge Rows

Sub MergeRows()

    Const mCol As Long = 1
    Const cCol As Long = 3
    Const MinRows As Long = 3 ' fixed
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    
    Dim rCount As Long: rCount = rg.Rows.Count
    If rCount < MinRows Then Exit Sub ' not enough rows
    
    rg.Sort Key1:=rg.Columns(mCol), Header:=xlYes
    
    Dim crg As Range: Set crg = rg.Columns(cCol)
    Dim cData(): cData = crg.Value
    Dim mData(): mData = rg.Columns(mCol).Value
    Dim dr As Long: dr = MinRows - 1
    
    Dim drg As Range, r As Long
    
    For r = MinRows To rCount
        If mData(r - 1, 1) = mData(r, 1) Then
            cData(dr, 1) = cData(dr, 1) & vbLf & cData(r, 1)
            If drg Is Nothing Then
                Set drg = rg.Rows(r)
            Else
                Set drg = Union(drg, rg.Rows(r))
            End If
        Else
            dr = dr + 1
            cData(dr, 1) = cData(r, 1)
        End If
    Next r
    
    If Not drg Is Nothing Then drg.Delete xlShiftUp: crg.Value = cData
    
    MsgBox "Rows Merged.", vbInformation
    
End Sub