gekleurde cellen tellen

[jack009]

hallo helpers

ik heb deze code gevonden op de site

Sub AllesTellen()
Dim c As Range
[B33: D33].Value = 0
For Each c In [B1:X31]
If c.Interior.ColorIndex = 3 Then
[B33].Value = [B33].Value + 1
ElseIf c.Interior.ColorIndex = 4 Then
[C33].Value = [C33].Value + 1
ElseIf c.Interior.ColorIndex = 5 Then
[D33].Value = [D33].Value + 1
End If
Next
End Sub

werkt prima telt netjes alle cellen met de 3 opgegeven kleuren
als ik de macro uitvoer,
nu is mijn vraag is het ook mogelijk deze ook automatisch de cellen in het bereik op te laten tellen, telkens als er een cel gekleurd wordt met één van de opgegeven kleuren.

groet

jack009

 

[danny147]

Beste jack009

Er is daarjuist een topic afgesloten met de zelfde vraag.

Zie deze topic.

Groetjes Danny. :thumb:

 

[jack009]

Beste jack009

Er is daarjuist een topic afgesloten met de zelfde vraag.

Zie deze topic.

Groetjes Danny. :thumb:

sorry voor de onduidelijkheid mijner zijde

de topic waar u naar refereert was inderdaad al afgesloten en daar was ik op door gegaan omdat ik nog een aanvulling zocht, maar mij werd verrzocht dat niet op die manier te doen
zie hieronder
@jack009 Graag een eigen vraag maken a.u.b. Het is niet netjes om in een ander zijn of haar vraag jouw probleem aan de orde te stellen. Bovendien is het verwarrend voor de helpers.

ik heb ook aangegeven dat de code prima werkt, ik zou alleen graag een aanvulling hebben zodat deze automatisch wordt uitgevoerd telkens als er een cel wordt gekleurd in het bereik met de opgegeven kleuren. dus dat ik niet steeds zelf de macro moet uitvoeren.
indien mogelijk uiteraard

groet

jack009

 

[danny147]

Beste jack009

Zet deze regel eerst en plaats de code in Blad1.

Private Sub Worksheet_Change(ByVal Target As Range)

en verwijder deze:

Sub AllesTellen()

Groetjes Danny. :thumb:

 

[jack009]

Beste jack009

Zet deze regel eerst en plaats de code in Blad1.

Private Sub Worksheet_Change(ByVal Target As Range)

en verwijder deze:

Sub AllesTellen()

Groetjes Danny. :thumb:

hallo Danny,

heb ik gedaan, maar er doet zich iets raars voor, het blijft hangen als of hij de bewerking oneindig blijft herhalen.

groet

jack

 

[Cobbe]

Het verkeerde antwoord op de verkeerde vraag.
Niet helemaal gelezen.

Stom hé?

 

[Cobbe]

Dit zou het moeten doen:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If intersect (target,Range("B1:X31")) is nothing then exit sub
[B33: D33].Value = 0
For Each c In [B1:X31]
If c.Interior.ColorIndex = 3 Then
[B33].Value = [B33].Value + 1
ElseIf c.Interior.ColorIndex = 4 Then
[C33].Value = [C33].Value + 1
ElseIf c.Interior.ColorIndex = 5 Then
[D33].Value = [D33].Value + 1
End If
Next
End Sub

Cobbe

 

[snb]

Private Sub Worksheet_Change(ByVal Target As Range)
   If not intersect (target,[B1:X31]) is nothing then
      [B33: E34].Value = 0
      For Each cl In [B1:X31]
         x=cl.interior.colorindex-1
         cells(33,x)=cells(33,x)+1
         cells(34,x)=cells(34,x)+cl.value
     Next
   End If
End Sub

 

[jack009]

Dit zou het moeten doen:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If intersect (target,Range("B1:X31")) is nothing then exit sub
[B33: D33].Value = 0
For Each c In [B1:X31]
If c.Interior.ColorIndex = 3 Then
[B33].Value = [B33].Value + 1
ElseIf c.Interior.ColorIndex = 4 Then
[C33].Value = [C33].Value + 1
ElseIf c.Interior.ColorIndex = 5 Then
[D33].Value = [D33].Value + 1
End If
Next
End Sub

Cobbe

Hallo Cobbe,

dit is wat ik bedoelde, werkt prima

hartelijk dank

groet

Jack009

 

[jack009]

Private Sub Worksheet_Change(ByVal Target As Range)
   If not intersect (target,[B1:X31]) is nothing then
      [B33: E34].Value = 0
      For Each cl In [B1:X31]
         x=cl.interior.colorindex-1
         cells(33,x)=cells(33,x)+1
         cells(34,x)=cells(34,x)+cl.value
     Next
   End If
End Sub

ik heb ook jouw oplossing geprobeerd, maar krijg een foutmelding en met foutopsporing is de volgende regel gekleurd
cells(33,x)=cells(33,x)+1

wat zou jouw oplossing anders behoren te doen dan die van cobbe, want die werkt goed, ben toch altijd benieuwd naar andere oplossingen

bedankt en groeten

jack009