Consolidation

[cccs16]

I would like to consolidate columns A2:I2 based on the criteria that A2:D2 are the same on the next row. I have attached photos of the whole document to provide how this is supposed to work. I cannot seem to figure out consolidation and I maybe overlooking it. I have the code pasted below. Thanks!

Code for Submit button:

Private Sub CommandButton1_Click()

Dim CTrk As Worksheet, CLog As Worksheet

Set CTrk = Sheet1
Set CLog = Sheet4
Set CLog2 = Sheet5

Dim Project As Range, Activity_Seq As Range, Dept As Range, Batch_Build As Range, Project_Name As Range, Passed_Test As Range, Failed_Test As Range, Failed_QA As Range, Built_Not_QA As Range, nTime As Date
Dim Qty_To_Produce As Range

Set Project = CTrk.Range("F7")
Set Activity_Seq = CTrk.Range("F9")
Set Dept = CTrk.Range("F11")
Set Batch_Build = CTrk.Range("F13")
Set Project_Name = CTrk.Range("F15")
Set Qty_To_Produce = CTrk.Range("F17")
Set Passed_Test = CTrk.Range("F19")
Set Failed_Test = CTrk.Range("F21")
Set Failed_QA = CTrk.Range("F23")
Set Built_Not_QA = CTrk.Range("F25")
nTime = Date

Dim PasteCell As Range, PasteCell2 As Range

If CLog.Range("A2") = "" Then
    Set PasteCell = CLog.Range("A2")
Else
    Set PasteCell = CLog.Range("A1").End(xlDown).Offset(1, 0)
End If

If CLog2.Range("A2") = "" Then
    Set PasteCell2 = CLog2.Range("A2")
Else
    Set PasteCell2 = CLog2.Range("A1").End(xlDown).Offset(1, 0)
End If

If CTrk.Range("F7") = "" Then
MsgBox "You must enter a Project number."
    ElseIf CTrk.Range("F9") = "" Then
        MsgBox "You must enter a Activity Sequence."
            ElseIf CTrk.Range("F11") = "" Then
            MsgBox "You must enter a Department."
                ElseIf CTrk.Range("F13") = "" Then
                MsgBox "You must enter a Batch & Build."
                    ElseIf CTrk.Range("F15") = "" Then
                    MsgBox "You must enter a Project Name."
                        ElseIf CTrk.Range("F17") = "" Then
                        MsgBox "You must enter 0 or any number for Qty to Produce"
                            ElseIf CTrk.Range("F19") = "" Then
                            MsgBox "You must enter 0 or any number for Passed Test"
                                ElseIf CTrk.Range("F21") = "" Then
                                MsgBox "You must enter a 0 or any number for Failed Test."
                                    ElseIf CTrk.Range("F23") = "" Then
                                    MsgBox "You must enter a 0 or any number for Failed QA."
                                        ElseIf CTrk.Range("F25") = "" Then
                                        MsgBox "You must enter a 0 or any number for Built Not QA."
                                        Exit Sub
                                    
Else

    Project.Copy PasteCell.Cells(1, 1)
    Project.Copy PasteCell2.Cells(1, 1)
    
    Activity_Seq.Copy PasteCell.Offset(0, 1)
    Activity_Seq.Copy PasteCell2.Offset(0, 1)
    
    Dept.Copy PasteCell.Offset(0, 2)
    Dept.Copy PasteCell2.Offset(0, 2)
    
    Batch_Build.Copy PasteCell.Offset(0, 3)
    Batch_Build.Copy PasteCell2.Offset(0, 3)
    
    Project_Name.Copy PasteCell.Offset(0, 4)
    Project_Name.Copy PasteCell2.Offset(0, 4)
    
    Passed_Test.Copy PasteCell.Offset(0, 5)
    
    Failed_Test.Copy PasteCell.Offset(0, 6)
    Qty_To_Produce.Copy PasteCell2.Offset(0, 6)
    
    Failed_QA.Copy PasteCell.Offset(0, 7)
    
    Built_Not_QA.Copy PasteCell.Offset(0, 8)
    
    MsgBox "Log submitted successfully!"
    
End If

If CLog.Range("J2") = "" Then
    CLog.Range("J2").Value = nTime
Else
    CLog.Range("J1").End(xlDown).Offset(1, 0).Value = nTime
End If

If CLog.Range("K2") = "" Then
    CLog.Range("K2") = "In-Progress"
Else
    CLog.Range("K1").End(xlDown).Offset(1, 0) = "In-Progress"
End If

' hiker95, 07/03/2015, ME865785
Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
With Sheets("Progress")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  With .Range("J2:J" & lr)
    .Formula = "=A2&B2&C2&D2"
    .Value = .Value
  End With
  .Range("A2:J" & lr).Sort key1:=.Range("J2"), order1:=1
  For r = 2 To lr
    n = Application.CountIf(.Columns(10), .Cells(r, 10).Value)
    If n > 1 Then
      .Range("G" & r).Value = Evaluate("=Sum(G" & r & ":G" & r + n - 1 & ")")
      .Range("A" & r + 1 & ":G" & r + n - 1).ClearContents
    End If
    r = r + n - 1
  Next r
  .Range("J2:J" & lr).ClearContents
  .Range("A2:I" & lr).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
Application.ScreenUpdating = True

End Sub

The main portion which my question pertains to

' hiker95, 07/03/2015, ME865785
Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
With Sheets("Progress")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  With .Range("J2:J" & lr)
    .Formula = "=A2&B2&C2&D2"
    .Value = .Value
  End With
  .Range("A2:J" & lr).Sort key1:=.Range("J2"), order1:=1
  For r = 2 To lr
    n = Application.CountIf(.Columns(10), .Cells(r, 10).Value)
    If n > 1 Then
      .Range("G" & r).Value = Evaluate("=Sum(G" & r & ":G" & r + n - 1 & ")")
      .Range("A" & r + 1 & ":G" & r + n - 1).ClearContents
    End If
    r = r + n - 1
  Next r
  .Range("J2:J" & lr).ClearContents
  .Range("A2:I" & lr).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
Application.ScreenUpdating = True