Waarden optellen die vaker voorkomen

[EdWel]

Mijn waarde snb, zullen we het hierbij laten?
Ik realiseer me -en jij waarschijnlijk met mij- dat het elkaar wijzen op spelfouten en daar op dit forum over te discusseren zowel kinderachtig als volslagen irrelevant is.
Hierbij aan Jelle2010 dan ook mijn welgemeende excuses voor deze brute interruptie van zijn vraag, waarbij ik hem overigens veel succes wens met de oplossing daarvan.

Groet, Ed

 

[EdWel]

Jelle,
Ter compensatie van mijn interruptie hier mijn oplossing:

Private Sub CommandButton1_Click()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   ActiveSheet.UsedRange.Sort Key1:=Range("B2"), Key2:=Range("D2"), Header:=xlGuess
   
   For r = 2 To UsedRange.Rows.Count + 100   'ivm Rows.Insert
      ttl = ttl + Cells(r, 5)
      If Not (Cells(r, 2) = Cells(r + 1, 2) And Cells(r, 4) = Cells(r + 1, 4)) Then
         Cells(r, 5).Borders(xlEdgeBottom).LineStyle = xlContinuous
         Rows(r + 1).Insert
         Cells(r + 1, 6) = ttl
         ttl = 0: r = r + 1
      End If
   Next r

   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub

Succes, Ed

 

[Jelle2010]

Private Sub CommandButton1_Click()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   UsedRange.Sort Key1:=Range("B2"), Key2:=Range("D2"), Header:=xlGuess
   
   For r = 2 To UsedRange.Rows.Count + 100   'ivm Rows.Insert
      ttl = ttl + Cells(r, 5)
      If Not (Cells(r, 2) = Cells(r + 1, 2) And Cells(r, 4) = Cells(r + 1, 4)) Then
         Cells(r, 5).Borders(xlEdgeBottom).LineStyle = xlContinuous
         Rows(r + 1).Insert
         Cells(r + 1, 6) = ttl
         Cells(r + 1, 1) = Cells(r, 1).Value
         Cells(r + 1, 2) = Cells(r, 2).Value
         Cells(r + 1, 3) = Cells(r, 3).Value
         Cells(r + 1, 4) = Cells(r, 4).Value
         ttl = 0: r = r + 1
      End If
   Next r
   
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   
   On Error Resume Next     ' In case there are no blanks
   Columns("F:F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
   Columns("E:E").Delete
   
End Sub

SUPERRRR EDWEL!!! Dit is even precies wat ik nodig had. Die code viel voor een leek als ik nog aan te passen. Ik heb de code dus nog een beetje aangepast en zo bereik ik mijn uiteindelijke resultaat. Nu nog even als textbestand opslaan en ik ben klaar.

Zowel SNB als EDWEL super bedankt voor jullie hulp!

Groeten,

Jelle2010