Herbers Excel/VBA-Archiv

Bestimmten Wert in doppelten Zeilen addieren | Herbers Excel-Forum

• Bestimmten Wert in doppelten Zeilen addieren von Timo vom 20.01.2010 13:39:58
• AW: Bestimmten Wert in doppelten Zeilen addieren - von Tino am 20.01.2010 14:14:31
  • @Tino-Array ??? - von robert am 20.01.2010 19:38:48
    • Summe in Spalte C - von Tino am 20.01.2010 20:11:22
      • ohne Re- Dimensionierung - von Tino am 20.01.2010 20:17:34
      • AW: Summe in Spalte C - von robert am 20.01.2010 20:44:01
        • so müsste es gehen. - von Tino am 20.01.2010 21:24:09
          • So geht es ! :-) Danke Tino-Gruß - von robert am 20.01.2010 21:39:59
• DANKE! - von Timo am 21.01.2010 11:37:22
  • ok. danke für die Rückmeldung. oT. - von Tino am 21.01.2010 13:32:16
• AW: Bestimmten Wert in doppelten Zeilen addieren - von Timo am 22.01.2010 00:00:33
  • AW: Bestimmten Wert in doppelten Zeilen addieren - von Tino am 22.01.2010 00:21:37
    • AW: Bestimmten Wert in doppelten Zeilen addieren - von Timo am 23.01.2010 12:17:24

Betrifft: Bestimmten Wert in doppelten Zeilen addieren von: Timo
Geschrieben am: 20.01.2010 13:39:58

Hallo zusammen,

zuerst einmal ein dickes Lob an dieses geniale Forum hier.
Eure Beiträge haben mir schon oft bei verzwickten Aufgabenstellungen geholfen.
Leider habe ich zu meinem aktuellen Problem noch keine Lösung gefunden.
Aber dies ist sicher kein Problem für Euch.

Die Lösung soll über VBA realisiert werden.

Problem:

Ich habe eine Tabelle mit 4 Spalten und sehr vielen Datensätzen.

Ich möchte gern, dass Excel die Werte in Spalte A, B und C in allen Zeilen vergleicht.
Wenn der Wert in Spalte A, B und C in mehreren Zeilen vorkommt, soll in den Zeilen die Werte in Spalte D
addiert werden und die doppelten Zeilen gelöscht werden.

Z.B.:

Musterkind 123 Apfel 2
Musterfrau 123 Birne 3
Musterkind 234 Apfel 3
Musterfrau 222 Melone 1
Musterfrau 123 Birne 2

soll dann so aussehen: (zweiter und letzter Eintrag sollen zusammengefasst werden)

Musterkind 123 Apfel 2
Musterfrau 123 Birne 5
Musterkind 234 Apfel 3
Musterfrau 222 Melone 1

Es soll also nur Zeilen betreffen, wo wirklich Spalte A, B und C gleich ist.
Diese Zeilen sollen dann zusammengefasst werden, indem der Wert in Spalte D addiert wird
und die doppelten Zeilen gelöscht werden.

Ich hoffe, ich konnte es einigermaßen verständlich rüberbringen...

Vielen Dank

Gruß Timo

Betrifft: AW: Bestimmten Wert in doppelten Zeilen addieren von: Tino
Geschrieben am: 20.01.2010 14:14:31

Hallo,
kannst mal diesen Code testen.

Sub Test()
Dim meAr(), tmpAr()
Dim myDic As Object
Dim sString As String
Dim A As Long, AA As Long

With Sheets("Tabelle1") 'Tabelle anpassen 
    Set myDic = CreateObject("Scripting.Dictionary")
    meAr = .Range("A2", .Cells(.Rows.Count, 4).End(xlUp)).Value2
    Redim Preserve tmpAr(1 To 3, 1 To Ubound(meAr))
    
    For A = 1 To Ubound(meAr)
     sString = meAr(A, 1) & meAr(A, 2) & meAr(A, 3)
     If Not myDic.exists(sString) Then
      myDic(sString) = 0
      AA = AA + 1
      tmpAr(1, AA) = meAr(A, 1)
      tmpAr(2, AA) = meAr(A, 2)
      tmpAr(3, AA) = meAr(A, 3)
     End If
     
     myDic(sString) = myDic(sString) + meAr(A, 4)
    Next A
    
    Redim Preserve tmpAr(1 To 3, 1 To AA)
    tmpAr = Application.Transpose(tmpAr)
    
    .Range("A2:D" & .Rows.Count).ClearContents
    .Range("A2").Resize(Ubound(tmpAr), Ubound(tmpAr, 2)) = tmpAr
    .Range("D2").Resize(myDic.Count) = Application.Transpose(myDic.items)
End With
End Sub

Gruß Tino

Betrifft: @Tino-Array ??? von: robert
Geschrieben am: 20.01.2010 19:38:48

hi Tino,

ich kapier diese Array's nicht :-((

wie müsste man den code ändern, wenn zB. die 3.spalte als mengensumme
ausgewiesen werden soll ?

gruß
robert

Betrifft: Summe in Spalte C von: Tino
Geschrieben am: 20.01.2010 20:11:22

Hallo Robert,
wenn der Aufbau der Tabelle so aussieht

	A	B	C	D
1	Überschrift	Überschrift	Überschrift	Überschrift
2	Musterkind	123	2	Apfel
3	Musterfrau	123	3	Birne
4	Musterkind	234	3	Apfel
5	Musterfrau	222	1	Melone
6	Musterfrau	123	2	Birne

Dann müsste man den Code so anpassen.

Sub Test()
Dim meAr(), tmpAr()
Dim myDic As Object
Dim sString As String
Dim A As Long, AA As Long

With Sheets("Tabelle1") 'Tabelle anpassen 
    Set myDic = CreateObject("Scripting.Dictionary")
    meAr = .Range("A2", .Cells(.Rows.Count, 4).End(xlUp)).Value2
    Redim Preserve tmpAr(1 To 4, 1 To Ubound(meAr))
    
    For A = 1 To Ubound(meAr)
     sString = meAr(A, 1) & meAr(A, 2) & meAr(A, 4)
     If Not myDic.exists(sString) Then
      myDic(sString) = 0
      AA = AA + 1
      tmpAr(1, AA) = meAr(A, 1)
      tmpAr(2, AA) = meAr(A, 2)
      tmpAr(4, AA) = meAr(A, 4)
     End If
     
     myDic(sString) = myDic(sString) + meAr(A, 3)
    Next A
    
    Redim Preserve tmpAr(1 To 4, 1 To AA)
    tmpAr = Application.Transpose(tmpAr)
    
    .Range("A2:D" & .Rows.Count).ClearContents
    .Range("A2").Resize(Ubound(tmpAr), Ubound(tmpAr, 2)) = tmpAr
    .Range("C2").Resize(myDic.Count) = Application.Transpose(myDic.items)
End With
End Sub

Gruß Tino

Betrifft: ohne Re- Dimensionierung von: Tino
Geschrieben am: 20.01.2010 20:17:34

Hallo Robert,
in diesem Fall kann man
ReDim Preserve tmpAr(1 To 4, 1 To AA)
auch weg lassen weil dieses Array nach unten sowieso leer und die gleiche größe wie meAr aufweist.

Gruß Tino

Betrifft: AW: Summe in Spalte C von: robert
Geschrieben am: 20.01.2010 20:44:01

hi Tino,

vorerst Danke, hier ein ausschnitt der datei mit ergebnisbereich

gruß
robert

https://www.herber.de/bbs/user/67362.xls

Betrifft: so müsste es gehen. von: Tino
Geschrieben am: 20.01.2010 21:24:09

Hallo,

Sub Test()
Dim meAr(), tmpAr()
Dim myDic As Object, myDicMenge As Object
Dim A As Long, AA As Long

With Sheets("Tabelle1") 'Tabelle anpassen 
    Set myDic = CreateObject("Scripting.Dictionary")
    Set myDicMenge = CreateObject("Scripting.Dictionary")
    meAr = .Range("A2", .Cells(.Rows.Count, 3).End(xlUp)).Value2
    Redim Preserve tmpAr(1 To Ubound(meAr), 1 To 3)
    
    For A = 1 To Ubound(meAr)
        If Not myDic.exists(meAr(A, 1)) Then
         myDic(meAr(A, 1)) = 0
         AA = AA + 1
         tmpAr(AA, 1) = meAr(A, 1)
        End If
     
        myDic(meAr(A, 1)) = myDic(meAr(A, 1)) + meAr(A, 2)
        myDicMenge(meAr(A, 1)) = myDicMenge(meAr(A, 1)) + meAr(A, 2) * meAr(A, 3)
    Next A
    
    .Range("A2:C" & .Rows.Count).ClearContents
    .Range("A2").Resize(Ubound(tmpAr)) = tmpAr
    .Range("B2").Resize(myDic.Count) = Application.Transpose(myDic.items)
    .Range("C2").Resize(myDicMenge.Count) = Application.Transpose(myDicMenge.items)
End With
End Sub

Gruß Tino

Betrifft: So geht es ! :-) Danke Tino-Gruß von: robert
Geschrieben am: 20.01.2010 21:39:59

Betrifft: DANKE! von: Timo
Geschrieben am: 21.01.2010 11:37:22

Hallo Tino,

funktioniert wunderbar.
Kann sein, dass die Tabelle noch erweitert werden muss.
Falls ich es nicht selbst hinbekomme, würde ich mich noch einmal bei Dir melden.

Vielen Dank für die schnelle Hilfe!

Gruß Timo

Betrifft: ok. danke für die Rückmeldung. oT. von: Tino
Geschrieben am: 21.01.2010 13:32:16

Betrifft: AW: Bestimmten Wert in doppelten Zeilen addieren von: Timo
Geschrieben am: 22.01.2010 00:00:33

Hallo Tino,

jetzt muss ich mich doch noch einmal melden.
Ich bin am verzweifeln, ich steige bei deinem Code einfach nicht dahinter.

Wie müsste denn der Code aussehen, wenn noch eine Spalte dazu kommt.

Und zwar so:

Musterkind 123 Apfel Rot 2
Musterfrau 123 Birne Gelb 3
Musterkind 234 Apfel Grün 3
Musterfrau 222 Melone Grün1
Musterfrau 123 Birne Grün 2

Es sollen aber nur Spalte A, B und C verglichen werden.
Wenn in einer weiteren Zeile Spalte A, B und C überein stimmt, dann halt wieder die letzte Spalte (E) dazu addieren und doppelte Zeilen löschen.
Was in Spalte D steht, spielt dabei keine Rolle.

So müsste das dann wieder aussehen (zweiter und letzter Eintrag zusammengefast)

Musterkind 123 Apfel Rot 2
Musterfrau 123 Birne Gelb 5
Musterkind 234 Apfel Grün 3
Musterfrau 222 Melone Grün1

Vielen Dank im Voraus

Gruß Timo

Betrifft: AW: Bestimmten Wert in doppelten Zeilen addieren von: Tino
Geschrieben am: 22.01.2010 00:21:37

Hallo,
müsste so funktionieren.

Sub Test()
Dim meAr(), tmpAr()
Dim myDic As Object
Dim sString As String
Dim A As Long, AA As Long

With Sheets("Tabelle1") 'Tabelle anpassen 
    Set myDic = CreateObject("Scripting.Dictionary")
    meAr = .Range("A2", .Cells(.Rows.Count, 5).End(xlUp)).Value2
    Redim Preserve tmpAr(1 To 4, 1 To Ubound(meAr))
    
    For A = 1 To Ubound(meAr)
     sString = meAr(A, 1) & meAr(A, 2) & meAr(A, 3)
     If Not myDic.exists(sString) Then
      myDic(sString) = 0
      AA = AA + 1
      tmpAr(1, AA) = meAr(A, 1)
      tmpAr(2, AA) = meAr(A, 2)
      tmpAr(3, AA) = meAr(A, 3)
      tmpAr(4, AA) = meAr(A, 4)
     End If
     
     myDic(sString) = myDic(sString) + meAr(A, 5)
    Next A
    
    Redim Preserve tmpAr(1 To 4, 1 To AA)
    tmpAr = Application.Transpose(tmpAr)
    
    .Range("A2").Resize(Ubound(meAr), Ubound(meAr, 2)).ClearContents
    .Range("A2").Resize(Ubound(tmpAr), Ubound(tmpAr, 2)) = tmpAr
    .Range("E2").Resize(myDic.Count) = Application.Transpose(myDic.items)
End With
End Sub

Gruß Tino

Betrifft: AW: Bestimmten Wert in doppelten Zeilen addieren von: Timo
Geschrieben am: 23.01.2010 12:17:24

Hallo,

funktioniert bestens!

Vielen Dank für Deine Bemühungen...

Gruß Timo

Beiträge aus den Excel-Beispielen zum Thema "Bestimmten Wert in doppelten Zeilen addieren"