Zellen vergleichen und andere summieren

Computer: Software & Programmierung Visual Basic
#1

Hallo ich habe mal wieder ein Problem:

In Excel97 habe ich Spalten mit folgenden Angaben:

Kfz-Zeichen Mengen Zeit
Kfz 1 30000 kg 18.11.07 08:33
Kfz 1 600 kg 18.11.07 16:44
Kfz 2 25000 kg 18.11.07 13:45
Kfz 2 700 kg 18.11.07 19:59
…

Es sollen alle Mengen addiert werden die zum gleichen Kfz-Zeichen gehören, das heißt Kfz1+Kfz1 (30000+600) und Kfz2+Kfz2 (25000+700)
das Ergebnis soll dann in einer neuzuerstellenden Zeile unter der letzten Menge der Kfz-Zeichen stehen, also so aussehen

Kfz-Zeichen Mengen Zeit
Kfz 1 30000 kg 18.11.07 08:33
Kfz 1 600 kg 18.11.07 16:44
30600 kg
Kfz 2 25000 kg 18.11.07 13:45
Kfz 2 700 kg 18.11.07 19:59
25700 kg
…

Wäre schön wenn mir jemand mit einem Script behilflich sein könnte. Ich weiß nie wie ich anfangen soll.

#2

Hallo,

warum VBA?

Eine analoge bzw. ähnliche Darstellung liefert die Excel-Funktion „Teilergebnisse“.
(Menü Daten --> Teilergebnisse) mit folgenden Einstellungen:

Gruppieren nach : Spalte KFZ
Unter Verwendung von : Summe
Teilergebnisse addieren zu: Spalte Kilo
Haken bei vorhanden Teilergebnisse ersetzen und
Ergebnisse unterhalb der Daten anzeigen

Einzige Voraussetzung ist, dass die Tabelle bereits nach KFZ sortiert ist, aber das sieht in Deinem Beispiel ja schon danach aus.

Wenn die Formatierung nicht gefällt, am besten die Liste in ein neues Blatt kopieren (nur Werte über Inhalte einfügen) und dort manuell oder ggf. per VBA umformatieren.

Gruß, tester!

#3

Nochmals Hallo,

also wenn’s unbedingt VBA sein soll, hier mal 2 Lösungsansätze:

Version 1 (Teilergebnissassistent wird genutzt)

Sub Version1()
Dim Blatt As Worksheet
Dim Bereich As Range
Dim zelle As Range

Set Blatt = ActiveSheet 'nach Bedarf festlegen
Set Bereich = Blatt.Range("A1:C7") 'nach Bedarf festlegen
Bereich.Cells(1, 1).Sort Key1:=Blatt.Columns(1), Header:=xlGuess 'Sortieren
Bereich.Subtotal 1, xlSum, Array(2), True, False, True
Set Bereich = Bereich.CurrentRegion 'erweiterter bereich
For Each zelle In Bereich.SpecialCells(xlCellTypeFormulas)
 If InStr(1, zelle.Formula, "subtotal", vbTextCompare) \> 0 Then
 zelle.Offset(0, -1).Value = zelle.Value
 zelle.Value = ""
 End If
Next zelle
Bereich.Rows(Bereich.Rows.Count).Delete 'Gesamtsumme löschen
Bereich.RemoveSubtotal 'Teilergebnisansicht wieder entfernen
End Sub

und Version 2:

Sub Version2()
Dim Blatt As Worksheet
Dim Bereich As Range
Dim MaxZeile As Double
Dim zeile As Double
Dim GruppWert As String
Dim GruppSumme As Double

Set Blatt = ActiveSheet 'nach Bedarf festlegen
Set Bereich = Blatt.Range("A1:C7") 'nach Bedarf festlegen
With Bereich
 MaxZeile = Bereich.Rows.Count
 zeile = 2 'Kopfzeile weglassen, falls keine Kopfzeile auf 1 setzen
 While zeile Viel Spaß beim Testen, tester!
1 Like
#4

In Excel97 habe ich Spalten mit folgenden Angaben:

Kfz-Zeichen Mengen Zeit
Kfz 1 30000 kg 18.11.07 08:33
Kfz 1 600 kg 18.11.07 16:44
Kfz 2 25000 kg 18.11.07 13:45
Kfz 2 700 kg 18.11.07 19:59
…

Es sollen alle Mengen addiert werden die zum gleichen
Kfz-Zeichen gehören, das heißt Kfz1+Kfz1 (30000+600) und
Kfz2+Kfz2 (25000+700)

Kfz-Zeichen Mengen Zeit
Kfz 1 30000 kg 18.11.07 08:33
Kfz 1 600 kg 18.11.07 16:44
30600 kg
Kfz 2 25000 kg 18.11.07 13:45
Kfz 2 700 kg 18.11.07 19:59
25700 kg

Hi Innie,
wie schon gesagt manuell mit dem Teilsummenassistennten ist man auch nicht zu langsam, aber okay, hier der Code:

Sub SummeKfz()
Range("A1").CurrentRegion.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), \_
 Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Selection.ClearOutline
End Sub

Gruß
Reinhard

#5

Hallo tester,

Danke für deine rasche Antwort, ich hab es leider nicht eher geschafft, es mal auszuprobieren und mit den Teilergebnissen funktioniert einwandfrei! Vielen Dank! Den Code werde ich mir trotzdem noch mal anschauen und auch testen.

Auch Danke an Reinhard

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]