AW: Einzelwerte aus Gesamtwert ermitteln
13.08.2003 11:46:40
Michael Brüggemann
Hallo Marcus,
dieser Code tut, was Du willst.
Achtung ! Es wird natürlich nur die ERSTE Lösung gefunden und bei großer Anzahl Werte wird das natürlich extrem langsam !
Option Explicit
Option Base 1
Sub Markiere_Werte()
Dim i, j, Idx As Integer
Dim intRow() As Long
Dim lngErgebnis, lngSumme, lngMaxRecords As Long
Dim wks As Worksheet
' Arbeitsblatt bestimmen
Set wks = ThisWorkbook.Sheets(1)
' Ergebnis (Zielwert) setzen (im Test in Zelle $C$3)
lngErgebnis = wks.Cells(1, 3).Value
' Maximale Anzahl Sätze im Arbeitsblatt als Dimension für Array bestimmen
lngMaxRecords = wks.UsedRange.Rows.Count
' Zähler zurücksetzen
i = 1
' Formatierung für alle Zellen in Spalte 1 auf automatisch setzen
Columns(1).Font.ColorIndex = xlAutomatic
' äußeren Zeilenzähler zurücksetzen
i = 1
' Index für Array mit Zeilennummern zurücksetzen
Idx = 1
' Array dimensionieren
ReDim intRow(lngMaxRecords)
' Spalte "A" durchlaufen, bis leere Zelle gefunden wird
Do While Not IsEmpty(wks.Cells(i, 1))
' Prüfsumme mit Zellwert initialisieren
lngSumme = wks.Cells(i, 1).Value
' Wenn die Prüfsumme <= Ergebis ist, ...
If lngSumme <= lngErgebnis Then
' ... dann Quellzeile merken
intRow(1) = i
' ... und Index des Arrays erhöhen
Idx = Idx + 1
End If
' Wenn Prüfsumme größer oder gleich Ergebnis, dann ...
If lngSumme < lngErgebnis Then
' inneren Zeilenzähler zurücksetzen
j = i + 1
' Spalte "A" durchlaufen, bis leere Zelle gefunden wird oder
' Prüfsumme gleich Ergebnis (Zielwert) ist
Do While Not IsEmpty(wks.Cells(j, 1)) And lngSumme <> lngErgebnis
' Wenn Prüfsumme + Zellwert <= Zielwert, dann ...
If lngSumme + wks.Cells(j, 1).Value <= lngErgebnis Then
' Prüfsumme um Zellwert erhöhen
lngSumme = lngSumme + wks.Cells(j, 1).Value
' Zeile merken
intRow(Idx) = j
' Index für Array hochzählen
Idx = Idx + 1
End If
' inneren Zeilenzähler hochzählen
j = j + 1
Loop
End If
' Wenn Prüfsumme gleich Zielwert, dann raus aus der Schleife
If lngSumme = lngErgebnis Then Exit Do
' Array dimensionieren, um Inhalt zu löschen
ReDim intRow(lngMaxRecords)
' Index des Arrays zurücksetzen
Idx = 1
' äußeren Zeilenzähler hochzählen
i = i + 1
Loop
' Array durchlaufen und registrierte Zellen mit rotem Font versehen
For i = 1 To 20
If intRow(i) = 0 Then Exit For
wks.Cells(intRow(i), 1).Font.ColorIndex = 3
Next i
If i = 1 Then MsgBox "Keine Werte markiert"
End Sub
CIAO
Michael