• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

gekleurde cellen tellen

Status
Niet open voor verdere reacties.

jack009

Gebruiker
Lid geworden
28 aug 2006
Berichten
223
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
 
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
 
Beste jack009 ;)

Zet deze regel eerst en plaats de code in Blad1.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

en verwijder deze:

Code:
Sub AllesTellen()

Groetjes Danny. :thumb:
 
Beste jack009 ;)

Zet deze regel eerst en plaats de code in Blad1.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

en verwijder deze:

Code:
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
 
Het verkeerde antwoord op de verkeerde vraag. :)
Niet helemaal gelezen.

Stom hé?
 
Laatst bewerkt:
Dit zou het moeten doen:

Code:
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
 
Code:
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
 
Laatst bewerkt:
Dit zou het moeten doen:

Code:
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
 
Code:
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
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan