Microsoft Excel

Herbers Excel/VBA-Archiv

Bestimmten Wert in doppelten Zeilen addieren | Herbers Excel-Forum


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

 ABCD
1ÜberschriftÜberschriftÜberschriftÜberschrift
2Musterkind1232Apfel
3Musterfrau1233Birne
4Musterkind2343Apfel
5Musterfrau2221Melone
6Musterfrau1232Birne


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"