AW: Mini-VBA-Befel für Datumsvergleich
02.09.2005 10:31:13
IngGi
Hallo Danikah,
es hat ein bisschen länger gedauert, war aber auch deutlich komplizierter als die erste Geschichte. Das Makro schreibt dir die Summen pro Monat und Kategorie in eine kleine Tabelle auf dem Tabellenblatt Gesamt, ab Zelle A2.
Option Explicit
Option Base 1
Sub Summieren()
Dim rng As Range
Dim a As Long, i As Long, s As Long, z As Long
Dim Dat() As Long, Zeile As Long
Dim b As Byte
Dim Daten() As String, tmp(4) As String
'Tabelle in Datenfeld einlesen
ReDim Daten(Sheets("Daten").Range("A65536").End(xlUp).Row + 1, 4)
For Each rng In Sheets("Daten").Range("A1:A" & Sheets("Daten") _
.Range("A65536").End(xlUp).Row)
Zeile = Zeile + 1
Daten(Zeile, 1) = rng.Value
Daten(Zeile, 2) = CStr(rng.Offset(0, 1).Value)
Daten(Zeile, 3) = CStr(rng.Offset(0, 2).Value)
Daten(Zeile, 4) = rng.Offset(0, 3).Value
Next 'rng
'Datenfeld mit Bubblesort nach Monaten sortieren
For a = 1 To UBound(Daten, 1) - 1
For i = 1 To UBound(Daten, 1) - 2
If Daten(i + 1, 1) < Daten(i, 1) Then
For b = 1 To 4
tmp(b) = Daten(i, b)
Daten(i, b) = Daten(i + 1, b)
Daten(i + 1, b) = tmp(b)
Next 'b
End If
Next 'i
Next 'a
'Positionen des jeweils ersten Elementes eines Datums in Daten() in Dat() schreiben
z = 1
ReDim Dat(1)
Dat(1) = 1
For s = 1 To UBound(Daten, 1) - 2
If Daten(s, 1) <> Daten(s + 1, 1) Then
z = z + 1
ReDim Preserve Dat(z)
Dat(z) = s + 1
End If
Next 's
ReDim Preserve Dat(z + 1)
Dat(z + 1) = UBound(Daten, 1)
'Datenfeld mit Bubblesort innerhalb der Monate nach Kategorien sortieren
For s = 1 To z
For a = Dat(s) To Dat(s + 1) - 1
For i = Dat(s) To Dat(s + 1) - 2
If Daten(i + 1, 4) < Daten(i, 4) Then
For b = 1 To 4
tmp(b) = Daten(i, b)
Daten(i, b) = Daten(i + 1, b)
Daten(i + 1, b) = tmp(b)
Next 'b
End If
Next 'i
Next 'a
Next 's
'Daten aus Datenfeld aufsummieren und Daten ausgeben
Set rng = Sheets("Gesamt").Range("A2")
s = 1
Do
s = s + 1
If Daten(s, 1) <> Daten(s - 1, 1) Or Daten(s, 4) <> Daten(s - 1, 4) Then
If rng.Offset(0, 1) = "" Then
rng = Daten(s - 1, 1)
rng.Offset(0, 1) = Val(Daten(s - 1, 2))
rng.Offset(0, 2) = Val(Daten(s - 1, 3))
rng.Offset(0, 3) = Daten(s - 1, 4)
Set rng = rng.Offset(1, 0)
Else
rng = Daten(s - 1, 1)
rng.Offset(0, 1) = rng.Offset(0, 1) + Val(Daten(s - 1, 2))
rng.Offset(0, 2) = rng.Offset(0, 2) + Val(Daten(s - 1, 3))
rng.Offset(0, 3) = Daten(s - 1, 4)
Set rng = rng.Offset(1, 0)
End If
Else
rng.Offset(0, 1) = rng.Offset(0, 1) + Val(Daten(s - 1, 2))
rng.Offset(0, 2) = rng.Offset(0, 2) + Val(Daten(s - 1, 3))
End If
Loop Until s = UBound(Daten, 1)
End Sub
Gruß Ingolf