AW: VBA: Werte nach Kriterien aufsummieren + ausge
27.10.2006 08:30:51
Heiko
Hallo Holger,
wenn trotz verschiedener und vertauschter Spalten in der Überschrift das Wort Projket für die Projektspalte und Betrag für die Betragspalte steht, dann könnte dieses Makro helfen.
Sub SummeT()
Dim bytSpalteP As Byte, bytSpalteB As Byte
Dim lngLastRow As Long, lngN As Long
Dim dblBetrag As Double
Dim strAlt As String
Dim rngFind As Range
Dim shtQuelle As Worksheet, shtZiel As Worksheet
' Start und ZielTabelle definieren, auf richtge Namen ANPASSEN
Set shtQuelle = Worksheets("Tabelle1")
Set shtZiel = Worksheets("Tabelle2")
' Projekt Spalte finden
Set rngFind = shtQuelle.Rows(1).Find("Projekt", LookIn:=xlValues)
If Not rngFind Is Nothing Then
bytSpalteP = rngFind.Column
End If
' Betrag Spalte finden
Set rngFind = shtQuelle.Rows(1).Find("Betrag", LookIn:=xlValues)
If Not rngFind Is Nothing Then
bytSpalteB = rngFind.Column
End If
' Raus wenn eins der beiden nicht zu finden ist
If (bytSpalteP = 0) Or (bytSpalteB = 0) Then
MsgBox "Es konnte keine Spalte PROJEKT bzw. BETRAG gefunden werden !", vbCritical, " Abbruch !"
Exit Sub
End If
' Letzte Zeile finden
lngLastRow = shtQuelle.Cells(Rows.Count, bytSpalteP).End(xlUp).Row
' Tabelle 2 vor neuen Einträgen löschen !!!
shtZiel.Cells.ClearContents
' 1. Zeile in die Zieltabelle kopieren.
shtQuelle.Rows(1).Copy shtZiel.Rows(1)
' Und nun los
strAlt = shtQuelle.Cells(2, bytSpalteP)
For lngN = 2 To lngLastRow + 1
If shtQuelle.Cells(lngN, bytSpalteP) = strAlt Then
dblBetrag = dblBetrag + shtQuelle.Cells(lngN, bytSpalteB)
Else
shtQuelle.Rows(lngN - 1).Copy shtZiel.Rows(shtZiel.Cells(Rows.Count, bytSpalteP).End(xlUp).Row + 1)
shtZiel.Cells(shtZiel.Cells(Rows.Count, bytSpalteP).End(xlUp).Row, bytSpalteB) = dblBetrag
dblBetrag = shtQuelle.Cells(lngN, bytSpalteB)
strAlt = shtQuelle.Cells(lngN, bytSpalteP)
End If
Next lngN
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !