Begriff in Zellen zählen, Farbe wechseln- aktuell

Hallo Leute.
Bitte um Idee.
https://www.herber.de/bbs/user/113980.xlsx
Bei hochgeladener Datei soll in der Zellen C22 aus den oberen eingerahmten Zellen den Begriff FBT gezählt und die akt. Anzahl ständig angezeigt werden.
Hat die Anzahl 2 (Sollwert lt. A22) erreicht soll die Zelle C22 grün einfärben. Bei zuviel - also 3 - gelb einfärben. Unter zwei soll sie rot bleiben.
Umsetzung unbedingt in VBA.
Menge:
Solche Zählzellen müsste ich dann mit verschiedene Begriffe (z.B. FBT, LAA, UVB, usw.) ca. 12 untereinander und über eine Breite von 30 Spalten.
die Eingabezellen oben werden ca. 60 STück sein erstellen.
Welches Ereignis soll ich verwenden, damit es ständig akt. ist und nicht eine zu große Rechenleistung verlangt?
Danke für eure Ideen.
lg STeve

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
hier Mappe: https://www.herber.de/bbs/user/113982.xlsm
hier Code:

Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Dim search As String
Dim i As Long, j As Long
On Error Resume Next
If target.Column = 3 Then
Application.EnableEvents = False
For i = 22 To Cells(Rows.Count, 2).End(xlUp).Row
search = Cells(i, 2).Value
Call count_values(search, j)
Cells(i, 3).Value = j
Next i
Call change_color
Application.EnableEvents = True
End If
End Sub
'Kann man auch in eine Function abändern
Private Sub count_values(ByVal countMe As String, ByRef amount As Long)
Dim rng As Range, c
Dim counter As Long
Dim ws As Worksheet
Dim firstAddress
On Error Resume Next
Set ws = ThisWorkbook.Sheets("Zaehlwerk")
With ws
Set rng = .Range(.Cells(.Rows.Count, 3), .Cells(1, 3))
With rng
Set c = .Find(countMe, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
counter = counter + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End With
amount = counter
End Sub
Private Sub change_color()
Dim ws As Worksheet
Dim i As Long, j As Long
Dim soll As Integer, ist As Integer
Set ws = ThisWorkbook.Sheets("Zaehlwerk")
With ws
i = .Cells(.Rows.Count, 2).End(xlUp).Row
For j = 22 To i
soll = .Cells(j, 1).Value
ist = .Cells(j, 3).Value
If ist > soll Then
.Cells(j, 3).Interior.ColorIndex = 3
Else
.Cells(j, 3).Interior.ColorIndex = 4
End If
Next j
End With
End Sub

Wenn es wirklich bei jeder änderung ausgeführt werden soll, dann musst du "If target.Column = 3" rausnehmen.

Beliebteste Forumthreads (12 Monate)

Begriff in Zellen zählen, Farbe wechseln- aktuell

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Begriff in Zellen zählen, Farbe wechseln- aktuell

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread