gekleurde cellen tellen

[mtb]

hoi,

mijn vraag is volgens mij redelijk simpel, alleen ik kom er niet uit

de bedoeling dat het aantal gekleurde cellen in een bereik word getelt, zie bijlage

 

[jheesterbeek]

Met behulp van macro's kun je zelf formules maken. In het bestand in de bijlage heb ik een formule geplaatst die het aantal gekleurde cellen telt.

Succes
John

 

[mtb]

John,

geweldig hij werkt perfect,

een fijne bijkomstigheid is dat je in de module heb aangeven wat de formule doet, ik heb hier nog wel een vraagje over, je schrijft

'Deze functie in je moduleblad plaatsen, met som_als_kleur(A1;A2:A33) worden alle cellen opgeteld 'in range(a2:a33) met als achtergrond kleur die van a1

ik begrijp niet precies wat je met het in het rood gekleurde gedeelte bedoelt, zou je dit nog ff toe willen lichten

thanks

 

[jheesterbeek]

Ik heb de tekst helaas niet aangepast. Ik had een formule staan waarbij je verwijst naar een kleur en een optelbereik. Als de cellen in het optelbereik dezelfde kleur hebben als de eerste cel, dan worden ze meegeteld. Bevatten ze een andere kleur, dan niet meer.
Deze formule heb ik iets aangepast tot de code die ik jou heb gegeven, alleen heb ik de tekst niet aangepast.

Hieronder de code:
'Deze functie in je moduleblad plaatsen, met som_als_kleur(A1;A2:A33) worden alle cellen opgeteld
'in range(a2:a33) met als achtergrond kleur die van a1

' Hou er wel rekening mee dat bij het wijzigen van alleen de kleur van de cel er geen automatische herberekening
' wordt uitgevoerd, dus even op F9 drukken. Bij het wijzigen van een waarde volgt wel een herbereking

' Met deze functie kun je 2 ranges op geven, niet meer zonder de functie aan te passen

Function Aantal_als_kleur(kleur As Range, Range1, Optional Range2) As Double
On Error GoTo ErrorHandler
Dim objCell As Range

Application.Volatile
Aantal_als_kleur = 0
CellBackGround = kleur.Interior.ColorIndex

For Each objCell In Intersect(Range1, _
Range1.Parent.UsedRange)
If objCell.Interior.ColorIndex = CellBackGround Then _
Aantal_als_kleur = Aantal_als_kleur + 1
Next objCell

If Not IsMissing(Range2) Then
For Each objCell In Intersect(Range2, _
Range2.Parent.UsedRange)
If objCell.Interior.ColorIndex = CellBackGround Then _
Aantal_als_kleur = Aantal_als_kleur + 1
Next objCell
End If
Exit Function
ErrorHandler: ' Hier wordt fout afgehandeld
Select Case Err.Number
Case 1004
'plakken geeft een foutmelding
MsgBox "Bij plakken wordt de kleur niet aangepast!", vbOKOnly, "Let op:"
Case Else
MsgBox "Er is een fout ontstaan" & Chr(13) & _
"Foutnummer: " & (Str(Err.Number) & Chr(13) & _
"Foutomschrijving: " & Err.Description)
End Select
End Function

 

[franç]

mtb, ik post dit even hier opdat je het zou zien (ik kan je nl. geen e-mail sturen).
Voeg in de code die ik je eerder gaf eens het volgende toe, juist boven "End with". Misschien heb je er iets aan.
For z = 6 To 50 Step 2
w = 0
For x = 5 To 23 Step 2
If .Cells(z, x).Interior.Color = vbGreen Then w = w + 1
Next: .Cells(z, 26) = w: Next

Niets wissen, end with en end sub blijven dus staan.

 

[jheesterbeek]

Voeg in de code die ik je eerder gaf eens het volgende toe

Waar kan ik de originele code vinden?

 

[franç]

een aantal berichten hieronder bij Getallen wegschrijven.