Te anexo la macro actualizada
Sub InsertarTotales()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Pagos")
h1.Copy
Set l2 = ActiveWorkbook
Set h2 = l2.Sheets(1)
'
h2.Columns("F").Delete
u = h2.Range("A" & Rows.Count).End(xlUp).Row
With h2.Sort
.SortFields.Clear
.SortFields.Add Key:=h2.Range("C4:C" & u), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange h2.Range("A3:E" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
wtotal = WorksheetFunction.Sum(h2.Range("E2:E" & u))
'
c1 = "B" 'columna de nombres
c2 = "E" 'columna de importes
u = h2.Range(c1 & Rows.Count).End(xlUp).Row
fin = u
ant = h2.Cells(u, c1)
tot = 0
For i = u To 3 Step -1
If h2.Cells(i, c1) <> ant Then
h2.Rows(fin + 1 & ":" & fin + 2).Insert
h2.Cells(fin + 1, c2) = tot
tot = 0
fin = i
End If
tot = tot + Val(h2.Cells(i, c2))
ant = h2.Cells(i, c1)
Next
u = h2.Range("E" & Rows.Count).End(xlUp).Row + 2
h2.Cells(u, "E") = wtotal
ruta = l1.Path & "\"
l2.SaveAs ruta & "totales.xlsx", FileFormat:=xlOpenXMLWorkbook
l2.Close
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
sal u dos