Treffer farblich markieren !
11.06.2009 08:14:53
Ernst
Dank eurer Hilfe ist dieser Code zustande gekommen der super funktioniert.
Bei der Trefferauswertung was das Datum betrifft (abgefragter Zeitraum)hätte ich noch eine Frage und zwar wie müsste der Code aussehen wenn die Treffer farblich hinterlegt werden .
Es sollte eine Msg Box info erscheinen Treffer im gesuchten Zeitraum werden jetzt in die Ausgabe felder übernommen.
Abschliessend sollten die Farbmarkierungen wieder deaktiviert werden.
Wäre für Lösungsvorschläge sehr Dankbar.
lg.Ernst
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim n As Integer
Dim S As Integer
Dim RL As Range
Dim Zx As Long
Dim RA As Range
Dim datStart As Date, datEnde As Date
If Target.Address = "$G$2" Then
If IsDate(Target.Value) And IsDate(Target.Offset(0, -2).Value) Then
datStart = Target.Offset(0, -2).Value
datEnde = Target.Value
If datEnde >= datStart Then
Zx = Worksheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
Target.Offset(0, 2).Value = 0
Target.Offset(0, 4).Value = 0
Target.Offset(0, 6).Value = 0
For Each RL In Worksheets("Archiv").Range("A5:A" & CStr(Zx))
S = Zuordnung(RL.Value)
Select Case S
Case 1
n = 2
Case 5
n = 4
Case 9
n = 6
End Select
Target.Offset(0, n).Value = Target.Offset(0, n).Value _
+ fncZaehlen(wks:=Worksheets("Archiv"), lngZeile:=RL.Row, _
DatumStart:=datStart, DatumEnde:=datEnde)
Next
Application.EnableEvents = True
End If
End If
End If
If Target.Address = "$K$4" Then
If IsDate(Target.Offset(0, -4).Value) And IsDate(Target.Offset(0, -2).Value) Then
datStart = Target.Offset(0, -4).Value
datEnde = Target.Offset(0, -2).Value
If datEnde >= datStart Then
Zx = Worksheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Row
Application.EnableEvents = False
Target.Offset(0, 2).Value = 0
For Each RL In Worksheets("Archiv").Range("A5:A" & CStr(Zx))
If RL.Value = Worksheets("Archiv").Range("K4").Value Then
Target.Offset(0, 2).Value = Target.Offset(0, 2).Value _
+ fncZaehlen(wks:=Worksheets("Archiv"), lngZeile:=RL.Row, _
DatumStart:=datStart, DatumEnde:=datEnde)
End If
Next
Application.EnableEvents = True
End If
End If
End If
End Sub
Function fncZaehlen(wks As Worksheet, lngZeile As Long, _
DatumStart As Date, DatumEnde As Date, Optional lngSpalte1 As Long = 2)
'Einträge innerhalb Datumsbereich in Zeile zählen
Dim lngSpalte As Long, lngSpalteL As Long
With wks
lngSpalteL = .Cells(lngZeile, .Columns.Count).End(xlToLeft).Column
For lngSpalte = lngSpalte1 To lngSpalteL
If .Cells(lngZeile, lngSpalte) >= DatumStart _
And .Cells(lngZeile, lngSpalte)
fncZaehlen = fncZaehlen + 1
End If
Next
End With
End Function
