Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1536to1540
1536to1540
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Beträge v Duplikaten summieren & Unikate ausgeben

Forumthread: Beträge v Duplikaten summieren & Unikate ausgeben

Beträge v Duplikaten summieren & Unikate ausgeben
26.01.2017 10:04:57
Anton
Hallo Zusammen,
ich habe in Spalte D mehrere gleiche Rechnungsnummer. Dies kommt daher, dass in Spalte N die einzelnen Beträge der Positionen einer Rechnung dargestellt sind. Die Rechnungsnummern können natürlich unterschiedlich oft vorkommen, je nach Rechnungspositionen.
Nun würde ich gerne die Zeile der Unikaten Rechnungsnummern mit summierten Betrag ausgeben. Ich hoffe, dass ist verständlich erklärt.
Kann mir evtl. jemand helfen?
Hier eine Beispielmappe:
https://www.herber.de/bbs/user/110898.xlsx
Mein Ansatz ist folgender, aber anscheinend sind meine Kenntnisse noch zu schlecht: 
Sub UnikateZählen()
Dim rngZelle As Range
Dim rngBereich As Range
Dim wksBlatt As Worksheet
Dim summe As Integer
Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1")
With wksBlatt
Set rngBereich = .Range("D4:D" & .Cells(.Rows.Count, 4).Row)
For Each rngZelle In rngBereich
If CountIf(rngBereich, rngZelle.Value) > 0 Then
sum = rngZelle.Offset(0, 13).Value
End If
Next rngZelle
End With
End Sub
Danke & VG,
Anton
Anzeige

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Beträge v Duplikaten summieren & Unikate ausgeben
26.01.2017 11:51:06
Anton
Habe es nun folgendermaßen gelöst.
Sub UnikateAuflisten()
Dim rngZelle As Range
Dim rngBereich As Range
Dim rngBereich2 As Range
Dim wksBlatt As Worksheet
Set wksBlatt = ThisWorkbook.Worksheets("Buchungen Navision")
With wksBlatt
Set rngBereich = .Range("D4:D" & .Cells(.Rows.Count, 4).End(xlUp).Row)
Set rngBereichSum = .Range("N4:N" & .Cells(.Rows.Count, 14).End(xlUp).Row)
For Each rngZelle In rngBereich
rngZelle.Offset(0, 19).Value = Application.WorksheetFunction.SumIf(rngBereich,  _
rngZelle.Offset.Value, rngBereichSum)
Next rngZelle
.Range("W4:W3000").Copy .Range("N4:N3000")
.Range("W4:W3000").ClearContents
.Range("A1:V3000").RemoveDuplicates Columns = 4, Header:=xlNo
End With
End Sub
Allerdings bekomme ich jetzt einen Laufzeitfehler 7: Nicht genügend Arbeitsspeicher. Liegt das evtl. an .removeduplicates ? In der Masterfile gibt es ca. 3000 Datensätze.
VG Anton
Anzeige
AW: Beträge v Duplikaten summieren
26.01.2017 13:04:51
Peter
Hallo Anton,
als VBA Lösung folgendes Makro, das das Ergebnis in das Tabellenblatt 2 ausgibt
Option Explicit
Public Sub Zusammenfassen()
Dim WkSh_Q    As Worksheet ' das Quell-Tabellenblatt - die Datenherkunft
Dim WkSh_Z    As Worksheet ' das  Ziel-Tabellenblatt - die Ausgabe
Dim objDic    As Object    ' das Data-Dictionary Object
Dim varArr    As Variant   ' ein Array der Daten
Dim lZeile    As Long      ' die Zeile des Arrays
Dim lZeile_Z  As Long      ' die Ausgabe-Zeile
Set WkSh_Q = ThisWorkbook.Worksheets("Tabelle1")
Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle2")
Set objDic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False ' das Bildschirem-Update unterdrücken
On Error GoTo Fehler_Ausgang
'     den Ausgabe-Bereich leeren/löschen
WkSh_Z.Cells.Range("A1:V" & WkSh_Z.Cells(WkSh_Z.Rows.Count, 1).End(xlUp).Row).ClearContents
'     die Überschrift kopieren
WkSh_Q.Range("A3:V3").Copy Destination:=WkSh_Z.Range("A3")
lZeile_Z = 4
With WkSh_Q
'     zur besseren Performance die Daten in ein Array speichern
varArr = .Range("A4:V" & .Cells(.Rows.Count, 1).End(xlUp).Row)
For lZeile = LBound(varArr) To UBound(varArr)
If IsNumeric(varArr(lZeile, 14)) Then ' ist Spalte N numerisch?
If Not objDic.Exists(varArr(lZeile, 4)) Then ' gibt es Spalte 4 - die  _
Rechnungsnummer bereits?
objDic(varArr(lZeile, 4)) = objDic(varArr(lZeile, 4)) + varArr(lZeile, 14)
WkSh_Z.Range("A" & lZeile_Z & ":V" & lZeile_Z) = varArr(lZeile, 1)
lZeile_Z = lZeile_Z + 1
Else ' nur noch die gesplitteten Rechnungs-Werte addieren
objDic(varArr(lZeile, 4)) = objDic(varArr(lZeile, 4)) + varArr(lZeile, 14)
End If
End If
Next lZeile
End With
'     das Ergebnis der Additionen (Zusammenfassungen) in Spalte N = 14 übertragen
WkSh_Z.Range("N4").Resize(objDic.Count) = Application.Transpose(objDic.items)
Fehler_Ausgang:
Set objDic = Nothing ' die Ressourcen löschen/freigeben
Set WkSh_Q = Nothing
Set WkSh_Z = Nothing
Application.ScreenUpdating = True ' das Bildschirm-Update wieder zulassen
'      gibt bzw. gab es Fehler?
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Gruß Peter
Anzeige
AW: Beträge v Duplikaten summieren
26.01.2017 13:23:45
Anton
Servus Peter,
vielen Dank! Das sieht gut aus. Ich kann es nur leider erst heute Abend testen, auf MAC hab ich kein Dictionary zur Verfügung :(
VG Anton
AW: Beträge v Duplikaten summieren
26.01.2017 13:36:07
Werner
Hallo Anton,
da ich mich jetzt schon mal hingesetzt habe hier auch noch meine Version.
https://www.herber.de/bbs/user/110912.xlsm
Gruß Werner
Anzeige
AW: Beträge v Duplikaten summieren
26.01.2017 13:45:42
Anton
Hallo Werner,
danke auch für Deine Lösung! Schaue ich mir heute Abend ebenfalls an.
VG Anton
AW: Beträge v Duplikaten summieren
26.01.2017 17:59:06
Peter
Hallo Anton,
die Array-Zeile muss natürlich so, wie in diesem Beispiel ausgegeben werden 
Option Explicit
'    Ich habe in Spalte D mehrere gleiche Rechnungsnummern.
'    Dies kommt daher, dass in Spalte N die einzelnen Beträge der Positionen einer Rechnung  _
dargestellt sind.
'    Die Rechnungsnummern können natürlich unterschiedlich oft vorkommen, je nach  _
Rechnungspositionen.
'    Nun würde ich gerne die Zeile der Unikaten Rechnungsnummern mit summiertem Betrag ausgeben. _
Public Sub Zusammenfassen()
Dim WkSh_Q    As Worksheet ' das Quell-Tabellenblatt - die Datenherkunft
Dim WkSh_Z    As Worksheet ' das  Ziel-Tabellenblatt - die Ausgabe
Dim objDic    As Object    ' das Data-Dictionary Object
Dim varArr    As Variant   ' ein Array der Daten
Dim lZeile    As Long      ' die Zeile des Arrays
Dim lZeile_Z  As Long      ' die Ausgabe-Zeile
Dim iSpalte   As Integer   ' die auszugebenden Spalten
Set WkSh_Q = ThisWorkbook.Worksheets("Tabelle1")
Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle2")
Set objDic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False ' das Bildschirem-Update unterdrücken
On Error GoTo Fehler_Ausgang
'     den Ausgabe-Bereich leeren/löschen
WkSh_Z.Cells.Range("A1:V" & WkSh_Z.Cells(WkSh_Z.Rows.Count, 1).End(xlUp).Row).ClearContents
'     die Überschrift kopieren
WkSh_Q.Range("A3:V3").Copy Destination:=WkSh_Z.Range("A3")
lZeile_Z = 4
With WkSh_Q
'        zur besseren Performance die Daten in ein Array speichern
varArr = .Range("A4:V" & .Cells(.Rows.Count, 4).End(xlUp).Row)
For lZeile = LBound(varArr) To UBound(varArr)
If IsNumeric(varArr(lZeile, 14)) Then ' ist Spalte N numerisch?
If Not objDic.Exists(varArr(lZeile, 4)) Then ' gibt es Spalte 4 - die  _
Rechnungsnummer bereits?
objDic(varArr(lZeile, 4)) = objDic(varArr(lZeile, 4)) + varArr(lZeile, 14)
For iSpalte = 1 To 22
WkSh_Z.Cells(lZeile_Z, iSpalte).Value = varArr(lZeile, iSpalte)
Next iSpalte
lZeile_Z = lZeile_Z + 1
Else ' nur noch die gesplitteten Rechnungs-Werte addieren
objDic(varArr(lZeile, 4)) = objDic(varArr(lZeile, 4)) + varArr(lZeile, 14)
End If
End If
Next lZeile
End With
'     das Ergebnis der Additionen (Zusammenfassungen) in Spalte N = 14 übertragen
WkSh_Z.Range("N4").Resize(objDic.Count) = Application.Transpose(objDic.items)
Fehler_Ausgang:
Set objDic = Nothing ' die Ressourcen löschen/freigeben
Set WkSh_Q = Nothing
Set WkSh_Z = Nothing
Application.ScreenUpdating = True ' das Bildschirm-Update wieder zulassen
'      gibt bzw. gab es Fehler?
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub

Gruß Peter
Anzeige
Erledigt...
26.01.2017 19:57:54
Anton
Beide Varianten funktionieren einwandfrei!
Danke für die Mühe.
VG Anton
AW: Gerne u. Danke für die Rückmeldung. o.w.T.
26.01.2017 21:04:11
Werner
AW: Erledigt...
26.01.2017 22:14:12
Peter
Hallo Anton,
dann hast du ja nun die Qual der Wahl - welche Mappe wirst du nehmen.
Viel Erfolg mit der Auswahl, danke für die Rückmeldung.
Gruß Peter
Anzeige

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige