PDA

Vollständige Version anzeigen : Werte einer Spalte anhand einer einer Schlüsselspalte aufsummieren


chasp
21.04.2009, 09:33
Hallo zusammen,

ich habe wiedermal ein kleines Problem, welches ich mit VBA lösen muss. Fürs leichtere Verständnis häng ich ein Excelsheet an.

In Spalte A ist der Schlüssel (bspw. Kontonr), nach dem gruppiert werden soll; Spalten B-C enthalten Werte, welche anhand der Schlüssel aufsummiert werden sollen.

Das Ergebnis, wie es mit VBA später aussehen soll, steht in den Spalten E-G. Jede Kontonr soll also nur 1x auftauchen und die Summe der jeweiligen Kontonr ausweisen.

Ich hoffe, ich hab es einigermassen verständlich geschrieben :-)

Danke für eure Hilfe
chasp

jinx
21.04.2009, 09:44
Moin, chasp,

sowohl Daten/Teilergebnis als auch Daten/Pivot erfüllen ohne Einsatz von VBA diese Anforderung, die Funktion SummeWenn gibt es als WorksheetFunction.SumIf auch in VBA...

chasp
21.04.2009, 09:55
Hi jinx,

danke für die Antwort, jedoch brauch ich das Ergebnis in einer Liste wie angegeben, d.h. Pivot Tabelle funktioniert nicht und Teilergebnis auch nicht. Am Besten wäre es, wenn ich das Ergebnis auf einem neuen Tabellenblatt in der angegebenen Form erhalten könnte. Mit Summewenn habe ich das Problem, dass ich via VBA erst einmal ermitteln muss, welche Schlüssel es alles gibt. Ich muss dazu sagen, dass ich leider nicht allzu viel Ahnung von VBA habe, deshalb wäre mir ein Codeschnippsel sicherlich sehr hilfreich!

Viele Grüsse
chasp

jinx
21.04.2009, 10:07
Moin, chasp,

wenn Dir die Codebeispiele ausreichen - ein Ansatz:

Sub EindeutigeSortierteWerte()

Dim rngBereich As Range
Dim rngZelle As Range
Dim colWerte As Collection
Dim lngZähler As Long
Dim lngLetzteZeile As Long

Const cstrTESTWERT As String = "Test"

Set colWerte = New Collection

colWerte.Add Item:=cstrTESTWERT, Key:=cstrTESTWERT
lngLetzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Set rngBereich = ActiveSheet.Range("A2:A" & lngLetzteZeile)

On Error Resume Next
For Each rngZelle In rngBereich
If Not rngZelle.Value = vbNullString Then
For lngZähler = 1 To colWerte.Count
If rngZelle.Value < colWerte(lngZähler) Then
colWerte.Add Item:=rngZelle.Value, Key:=CStr(rngZelle.Value), Before:=lngZähler
End If
Next lngZähler
colWerte.Add Item:=rngZelle.Value, Key:=CStr(rngZelle.Value)
End If
Next rngZelle
On Error GoTo 0

colWerte.Remove cstrTESTWERT

rngBereich.ClearContents

Set rngBereich = rngBereich.Resize(colWerte.Count)

lngZähler = 0
For Each rngZelle In rngBereich
lngZähler = lngZähler + 1
rngZelle.Value = colWerte(lngZähler)
Next rngZelle

End Sub
Oder
Public Sub SpezialfilterPerDictionary()

Dim objDicAnzahl As Object
Dim objDicSumme1 As Object
Dim objDicSumme2 As Object
Dim objDicSumme3 As Object
Dim varArrBereich As Variant
Dim lngZähler As Long

Set objDicAnzahl = CreateObject("Scripting.Dictionary")
Set objDicSumme1 = CreateObject("Scripting.Dictionary")
Set objDicSumme2 = CreateObject("Scripting.Dictionary")
Set objDicSumme3 = CreateObject("Scripting.Dictionary")

objDicAnzahl("Namen") = "Anzahl"
objDicSumme1("Namen") = "Summe " & [B1]
objDicSumme2("Namen") = "Summe " & [C1]
objDicSumme3("Namen") = "Summe " & [D1]

varArrBereich = Range("A1").CurrentRegion
For lngZähler = 2 To UBound(varArrBereich)
objDicAnzahl(varArrBereich(lngZähler, 1)) = _
objDicAnzahl(varArrBereich(lngZähler, 1)) + 1
objDicSumme1(varArrBereich(lngZähler, 1)) = _
objDicSumme1(varArrBereich(lngZähler, 1)) + varArrBereich(lngZähler, 2)
objDicSumme2(varArrBereich(lngZähler, 1)) = _
objDicSumme2(varArrBereich(lngZähler, 1)) + varArrBereich(lngZähler, 3)
objDicSumme3(varArrBereich(lngZähler, 1)) = _
objDicSumme2(varArrBereich(lngZähler, 1)) + varArrBereich(lngZähler, 4)
Next lngZähler

Range("G1").Resize(objDicAnzahl.Count) = WorksheetFunction.Transpose(objDicAnzahl.keys)
Range("H1").Resize(objDicAnzahl.Count) = WorksheetFunction.Transpose(objDicAnzahl.Items)
Range("I1").Resize(objDicAnzahl.Count) = WorksheetFunction.Transpose(objDicSumme1.Items)
Range("J1").Resize(objDicAnzahl.Count) = WorksheetFunction.Transpose(objDicSumme2.Items)
Range("K1").Resize(objDicAnzahl.Count) = WorksheetFunction.Transpose(objDicSumme3.Items)

Range("A1:K1").EntireColumn.AutoFit

Set objDicSumme3 = Nothing
Set objDicSumme2 = Nothing
Set objDicSumme1 = Nothing
Set objDicAnzahl = Nothing

End Sub

chasp
21.04.2009, 10:16
Hallo,

ja super, das sollte für mich ausreichend sein :-)

Danke & Grüsse
chasp