VBA Grouping Concatenate best way to handle, based on data in column

Hi all,
I have been working on a grouping of data in Column A based on data in column D. if the data in Column D matches next row in D then Concatenate data in column A and delete that line

any help appreciated to steer me in right direction
thanks regards Peter

Data Sample.jpg




My code so far

Sub CommandButton2_Click()
Dim x               As Integer
Dim MyTimer         As Double
x = MsgBox("This with now Group all Data IN Column A and Sheet1!", vbOKCancel)
If x = 2 Then Exit Sub
If x = 1 Then
MsgBox (" Application.EnableEvents = False")
 'Application.EnableEvents = False
 
     Dim Lastrow As Long, r As Long
    Application.ScreenUpdating = False
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
  
  'status bar code loop
   ' For j = 1 To 50
    
    For r = Lastrow To 2 Step -1
        If Range("D" & r).Value = Range("D" & r - 1).Value Then
            Range("A" & r).Value = Range("A" & r - 1).Value & "_" & Range("A" & r).Value
            Rows(r).Delete xlShiftUp
        
        End If
        'status bar code line under
        ' Application.StatusBar = "Progress: " & r & " of " & Lastrow & ": " & Format(r / Lastrow, "0%")
    Next r
 
    ActiveSheet.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
 
 
 End If
 
 End Sub

Originally Posted by LordLoki

Actually your way to loop through the range is correct and does not need Change when you start from the Bottom you do not screw up the process by deleteing a row.
Your code is perfectly fine you just delete the wrong row :D



it needs to be

 Rows(r-1).Delete xlShiftUp

Sub CommandButton2_Click()
Dim x               As Integer
Dim MyTimer         As Double
x = MsgBox("This with now Group all Data IN Column A and Sheet1!", vbOKCancel)
If x = 2 Then Exit Sub
If x = 1 Then
MsgBox (" Application.EnableEvents = False")
 'Application.EnableEvents = False
 
     Dim Lastrow As Long, r As Long
    Application.ScreenUpdating = False
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
  
  'status bar code loop
   ' For j = 1 To 50
    
    For r = Lastrow To 2 Step -1
        If Range("D" & r).Value = Range("D" & r - 1).Value Then
            Range("A" & r).Value = Range("A" & r - 1).Value & "_" & Range("A" & r).Value
            Rows(r-1).Delete xlShiftUp
        
        End If
        'status bar code line under
        ' Application.StatusBar = "Progress: " & r & " of " & Lastrow & ": " & Format(r / Lastrow, "0%")
    Next r
 
    ActiveSheet.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
 
 
 End If
 
 End Sub

Edit: Also i wanna mention that the initial code with the for loop performs around 33% better than the solution with the while loop. with a small data set that is not really noticable but in a dataset with 50k rows for example the for loop is running through in 2 minutes and the while loop needs 3 minutes which is a big difference.

You could speed up the process even more by reading everything into an array loop through that and only write back the values that you need. but unless you have a massive amount of Data that would not make much noticable difference.

Hi LordLoki,

Doh! thanks and yes that works, what is the best way to ignore the blank cells as this code looks at these as a duplicate but I don't want these to be grouped

thanks also for your info about performance

regards Peter