AW: daten aus tabelle in listbox
13.06.2008 20:26:00
Chris
Servus Ralf,
ich erklär dir jetzt mal ganz genau meinen Code, Zeile für Zeile. Und du sagst mir, ob z.B. jeder Monat ein eigenes Tabellenblatt hat, oder wie gestaltet sich das mit dem bezug auf die Daten des aktuellen Monats. stehen die gesamten Jahresdaten in einem Sheet, oder nur die Monatsdaten?
Private Sub ListBoxFüllen()
Dim lngRow As Long, lnglast As Long
ListBox1.Clear 'löscht die Eintragungen in Listbox
ListBox1.ColumnCount = 2 'legt die anzahl der Spalten fest x _
bis z
ListBox1.ColumnWidths = "150;30" 'legt die grösse der spaltenlänge in _
listbox fest
ListBox1.TextAlign = fmTextAlignLeft
With ActiveSheet ' mit aktuell aktiviertem Sheet
Dim SachArray() As Variant, PreisArray() As Variant, SachArrayNeu() As Variant
Dim lngLetzte As Long, z As Long, x As Long
Dim OG&, i&, j&, k&, h, y As Variant ' Variablendeklaration
lngLetzte = IIf(IsEmpty(.Cells(Rows.Count, 25)), .Cells(Rows.Count, 25).End(xlUp).Row, Rows. _
Count) 'letzte aus spalte Y auslesen
ReDim SachArray(1 To lngLetzte) ' zum Einlesen der Produkte einen Array dimensinoieren und zwar _
in der Größe der vorhandenen Einträge in der Spalte Y
For z = LBound(SachArray()) To UBound(SachArray()) ' Array einlesen Sachen (spalte Y dsw. ,25)
SachArray(z) = .Cells(z, 25)
Next z
OG = UBound(SachArray()) ' array sortieren ist einfach sortieren, könnte man auch weglassen, _
ich hab's aber gern geordnet
k = OG \ 2
While k > 0
For i = LBound(SachArray()) To OG - k
j = i
While (j >= 0) And (SachArray(j) > SachArray(j + k))
h = SachArray(j)
SachArray(j) = SachArray(j + k)
SachArray(j + k) = h
If j > k Then
j = j - k
Else
j = LBound(SachArray())
End If
Wend
Next i
k = k \ 2
Wend
For z = UBound(SachArray()) To LBound(SachArray()) + 1 Step -1 ' doppelte im eingelesenen Array _
aus Spalte Y entfernen, weil du ja z.B. nur einmal Ölfilter da stehen haben willst
If SachArray(z) = SachArray(z - 1) Then ' wenn der Vorgänger = dem aktuellen, dann setzte _
den aktuellen auf 0
SachArray(z) = ""
End If
Next z
x = 0 ' ab hier wird ein neuer Array aufgebaut, um für die spätere Suchschleife nur die _
einzelnen vorkommenden Produkte zu haben
For z = LBound(SachArray()) To UBound(SachArray()) ' neuen Array einlesen mit Einzelprodukten( _
ohne doppelte)
If SachArray(z) "" Then
ReDim Preserve SachArrayNeu(x) ' Array neu dimensionieren ohne den alten Wert zu _
verlieren
SachArrayNeu(x) = SachArray(z)
x = x + 1 ' deswegen hier immer um eins hochzählen
End If
Next z
Dim rSuche As Range, rFinde As Range, strErste As String
Dim dblSumme As Double
Set rFinde = .Range("Y:Y")
For z = LBound(SachArrayNeu()) To UBound(SachArrayNeu()) ' Schleife um Summen zu ermitteln fü _
das jeweilige Produkt, hier findet die Find-methode Anwendung, um nicht jede Zeile durchlaufen zu müssen (kostet Zeit)
Set rSuche = rFinde.Find(what:=SachArrayNeu(z), LookAt:=xlWhole, LookIn:=xlValues)
If Not rSuche Is Nothing Then ' bei Treffer die Adresse des ersten Fundes merken
strErste = rSuche.Address
Do ' mach das solange, bis
If IsNumeric(rSuche.Offset(0, 1)) Then ' da Summenbildung, wenn der Wert numerisch ist, _
dann
dblSumme = dblSumme + rSuche.Offset(0, 1) 'summiere auf und zwar die Zelle neben _
dem Suchbegriff, z.B. Ölfilter
End If
Set rSuche = rFinde.FindNext(rSuche) ' den Suchbegriff neu setzten, da Schleife, sonst _
findet er nur den ersten Eintrag
Loop While Not rSuche Is Nothing And rSuche.Address strErste
End If
With ListBox1 ' einlesen der Listbox
.ColumnCount = 2
.AddItem SachArrayNeu(z) ' Produktnamen
.List(z, 1) = Format(dblSumme, "#,##0.00\") ' die jeweilige Summe für die produkte
End With
dblSumme = 0 ' summe zwecks Schleife wieder auf 0 setzten, sonst würde der Wert der anderen _
auf die Summe des ersten Suchbegriffes aufaddiert
Next z
Set rSuche = Nothing ' Objekte zurücksetzten
Set rFinde = Nothing
End With
End Sub
den 2. Sortieralgorithmus braucht man nicht wirklich, deswegen, habe ich ihn aus dem Code herausgenommen.
Gruß
Chris