VBA Combine Rows

[decadence]

Hi I am trying to combine Rows based on duplicate values but need to comma delimit one columns of cells at the same time, Currently I am using the code below however it takes a long time when there is a lot of data, can someone help make this process faster please

Sub CombineRows()
'
Dim j As Long, c As Range

    Application.ScreenUpdating = False
    j = 1
    Do While j < ActiveSheet.UsedRange.Rows.Count
        Set c = Cells(j, 4)
        If Not c.Value = "" Then
            If c.Value = c.Offset(1).Value Then
                With c
                    .Offset(, 2).Value = .Offset(, 2).Value & "," & .Offset(1, 2).Value
                    .Offset(1).EntireRow.Delete
                End With
            Else
                j = j + 1
            End If
        End If
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Fluff]

How about

Sub decadence()
   Dim i As Long
   Dim Rng As Range
   
   For i = Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
      If Cells(i, 4) = Cells(i - 1, 4) And Cells(i, 4) <> "" Then
         Cells(i - 1, 6) = Cells(i - 1, 6) & "," & Cells(i, 6).Value
         If Rng Is Nothing Then Set Rng = Rows(i) Else Set Rng = Union(Rng, Rows(i))
      End If
   Next i
   If Not Rng Is Nothing Then Rng.Delete
End Sub

 

[decadence]

Thank you Fluff, it's perfect

 

[Fluff]

You're welcome & thanks for the feedback.