unire e sommare due righe

Sub CopiaIncolla()
LR = Cells(Rows.Count, "A").End(xlUp).Row
numvuote = WorksheetFunction.CountBlank(Range("B8:B" & LR))
numpiene = LR - numvuote
Range("A8:G" & numpiene).Copy
Range("A8:G" & numpiene).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Range("A" & numpiene + 1 & ":G" & LR).ClearContents
LR = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range("A7:G" & LR)
With ActiveWorkbook.Worksheets(1).Sort
      .SortFields.Clear
      .SortFields.Add Key:=Range( _
        "B8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange Rng
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
End With
J = 8
Direction = Cells(J, 1).Value
Do While Direction <> ""
   Do While Cells(J + 1, "B").Value = Cells(J, "B").Value
      Cells(J, "E").Value = Cells(J + 1, "E").Value + Cells(J, "E").Value
      Cells(J, "G").Value = Cells(J + 1, "G").Value + Cells(J, "G").Value
      Rows(J + 1).Delete
    Loop
    J = J + 1
    Direction = Cells(J, 1).Value
Loop
End Sub