Doppelte Einträge summieren + löschen

ben · 1970-01-01T00:00:00+00:00

Hallo zusammen, ich habe eine Excel Liste mit versch. Einträgen, bei denen in der Spalte C (ID Nummer) einige Einträge doppelt sind. Diese doppelten Einträge werden per VBA Code gelöscht. Jetzt sollen aber die Mengen in Spalte E der gelöschten Einträge aufsummiert werden. Bsp.: alle doppelten Einträge mit der ID Nummer ...16 werden gelöscht. Die ID Nummer ...16 kommt 3 mal vor, mit den Mengen 1,3 und 3. Am Ende soll also die ID Nummer ...16 nur noch einmal in der Liste vorkommen mit der aufsummierten Menge 7 in Spalte E. Anbei eine Beispiel Datei mit dem bereits existerien VBA Code für die Löschung doppelter Einträge. Danke für eure Hilfe! Gruß Ben

Hallo Ben,
das sollte es tun.

Private Sub CommandButton1_Click()
  Dim rng As Range, lngLast As Long

  lngLast = Application.Max(2, Cells(Rows.Count, 3).End(xlUp).Row)

  Columns(6).Insert

  Range(Cells(2, 6), Cells(lngLast, 6)).Formula = _
    "=IF(COUNTIF($C$2:C2,C2)=1,SUMIF($C$2:$C$" & lngLast & ",C2,$E$2:$E$" & lngLast & "),NA())"

  Range(Cells(2, 6), Cells(lngLast, 6)) = Range(Cells(2, 6), Cells(lngLast, 6)).Value

  On Error Resume Next
  Set rng = Columns(6).SpecialCells(xlCellTypeConstants, xlErrors)
  On Error GoTo 0

  If Not rng Is Nothing Then rng.EntireRow.Delete

  Range(Cells(2, 5), Cells(lngLast, 5)) = Range(Cells(2, 6), Cells(lngLast, 6)).Value
  Columns(6).Delete

  Set rng = Nothing
End Sub

Gruß Sepp

Hallo ben,
so könnte es funktionieren:

Option Explicit
Public Sub Zusammenfassen()
Dim WkSh       As Worksheet ' das zu bearbeitende Tabellenblatt
Dim lLetzte    As Long      ' die letzte belegte Zeile in Spalte C
Dim lZeile     As Long      ' For/Next Schleifen-Index - die Zeile
   Application.ScreenUpdating = False
   Set WkSh = ThisWorkbook.Worksheets("Tabelle1")
   lLetzte = WkSh.Cells(Rows.Count, 3).End(xlUp).Row

   With WkSh
' die Daten gemäß der Spalte A aufsteigend sortieren
      WkSh.Range("C2:E" & lLetzte).Sort _
         Key1:=WkSh.Range("C2"), Order1:=xlAscending, _
         Header:=xlGuess, OrderCustom:=1, _
         MatchCase:=False, Orientation:=xlTopToBottom
' doppelte ermitteln und zusammenführen
      lLetzte = WkSh.Cells(Rows.Count, 3).End(xlUp).Row
      For lZeile = lLetzte To 2 Step -1
         If WkSh.Cells(lZeile, 3).Value = WkSh.Cells(lZeile - 1, 3).Value Then
            WkSh.Cells(lZeile - 1, 5).Value = WkSh.Cells(lZeile - 1, 5).Value + _
            WkSh.Cells(lZeile, 5).Value
            WkSh.Rows(lZeile).Delete Shift:=xlUp
         End If
      Next lZeile
   End With

   Application.ScreenUpdating = True
End Sub
Gruß Peter

Doppelte Einträge summieren + löschen

Forumthread: Doppelte Einträge summieren + löschen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Doppelte Einträge summieren + löschen

Forumthread: Doppelte Einträge summieren + löschen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread