In Spalte Gleiche Kat. suchen und addieren (VBA)

Hallo,
in meinem Datenbestand habe ich in der Spalte V sowas wie Kategoriene. Die Kategorien können mehrmals vorkommen. Hinter den Kategorien in Spalte W hat es Preise. Beispiel:
V__________W
Werkzeug___100,00
Essen______300,00
Urlaub______50,00
Werkzeug___300,00
Essen______150,00
Urlaub______280,00
usw.
Ich möchte nun die komplette Spalte mit einer Schleife durcharbeiten und alle Datensätze mit gleichen Kategorien zu einem neuem datensatz addieren, damit ich jeweils die Gesamtsumme sehen kann. Als Ergebnis sollte dann das raukommen:
Werkzeug___400,00
Essen______450,00
Urlaub______330,00
Dieses Ergebnis soll dann zB. auf das Blatt "Zusammenfasssung" ab dem Bereich A5 geschrieben werden.
Kann sich das jemand vorstellen, wie man das machen könnte, Würde mir viel weiterhelfen.
Danke und Grüße
Joachim

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub SummeWerteProKategorie() Dim lngZ As Long, lngP As Long Dim colKat As New Collection Dim arrKat(), arrWerte() On Error Resume Next 'Zur Fehlervermeidung bei bereits vorhandenen Kategorien For lngZ = 2 To Cells(Rows.Count, 22).End(xlUp).Row Err.Clear 'Fehler löschen colKat.Add Cells(lngZ, 22), Cells(lngZ, 22) If Err = 0 Then ReDim Preserve arrKat(colKat.Count - 1) arrKat(UBound(arrKat)) = Cells(lngZ, 22) ReDim Preserve arrWerte(colKat.Count - 1) arrWerte(UBound(arrWerte)) = Cells(lngZ, 23) Else lngP = Application.Match(Cells(lngZ, 22), arrKat, 0) - 1 arrWerte(lngP) = arrWerte(lngP) + Cells(lngZ, 23) End If Next Sheets.Add 'Neues Blatt anlegen und aktivieren [A1:B1] = Array("Kategorien :", "Summe :") 'Kategorien und Werte in das neue Blatt übertragen : For lngZ = 1 To colKat.Count Cells(lngZ + 1, 1) = arrKat(lngZ - 1) Cells(lngZ + 1, 2) = arrWerte(lngZ - 1) Next End Sub

Hallo Jockel,
also auf meinem PC (ebenfalls XL2003) funktioniert der code einwandfrei : Die Daten werden in dem neuen Blatt ausgegeben.
Sicherheitshalber kann man dieses Blatt aber auch noch explizit aktivieren
Änderungen zur vorherigne Codeversion siehe rote Codezeilen

Sub SummeWerteProKategorie()
Dim lngZ As Long, lngP As Long, shNeu As Worksheet
Dim colKat As New Collection
Dim arrKat(), arrWerte()
On Error Resume Next 'Zur Fehlervermeidung bei bereits vorhandenen Kategorien
For lngZ = 2 To Cells(Rows.Count, 22).End(xlUp).Row
Err.Clear 'Fehler löschen
colKat.Add Cells(lngZ, 22), Cells(lngZ, 22)
If Err = 0 Then
ReDim Preserve arrKat(colKat.Count - 1)
arrKat(UBound(arrKat)) = Cells(lngZ, 22)
ReDim Preserve arrWerte(colKat.Count - 1)
arrWerte(UBound(arrWerte)) = Cells(lngZ, 23)
Else
lngP = Application.Match(Cells(lngZ, 22), arrKat, 0) - 1
arrWerte(lngP) = arrWerte(lngP) + Cells(lngZ, 23)
End If
Next
Set shNeu = Sheets.Add 'Neues Blatt anlegen und aktivieren
shNeu.Activate
[A1:B1] = Array("Kategorien :", "Summe :")
'Kategorien und Werte in das neue Blatt übertragen :
For lngZ = 1 To colKat.Count
Cells(lngZ + 1, 1) = arrKat(lngZ - 1)
Cells(lngZ + 1, 2) = arrWerte(lngZ - 1)
Next
End Sub

Gruß , NoNet
PS: Deutschland spielt "Vier gewinnt" :
gegen 4:0 gegen 4:1 gegen 4:0 gegen ?:? ;-)

Sheets.Add.Name = "Zusammenfassung" 'Neues Blatt anlegen und aktivieren With Sheets("Zusammenfassung") .[A1:B1] = Array("Kategorien :", "Summe :") 'Kategorien und Werte in das neue Blatt übertragen : For lngZ = 1 To colKat.Count .Cells(lngZ + 1, 1) = arrKat(lngZ - 1) .Cells(lngZ + 1, 2) = arrWerte(lngZ - 1) Next End With End Sub

Beliebteste Forumthreads (12 Monate)

In Spalte Gleiche Kat. suchen und addieren (VBA)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

341 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

In Spalte Gleiche Kat. suchen und addieren (VBA)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

341 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread