optellen van gekleurde cellen adv een datum

[DeCor]

Hoi,

Ik zou de gekleurde cellen moeten optellen wanneer ze voor een bepaalde datum vallen bij sheet "IN" en wanneer ze voor en na een datum vallen bij sheet "UIT"

Meer uitleg bij het voorbeeldje in bijlage.

Nu worden de kleuren geteld met een module, maar een andere methode is ook goed.

Bekijk bijlage test voor optellen volgens kleur en datum.xls

Alvast bedankt,

Mvg,

 

[HSV]

Probeer het zo eens.

Function CountColor(rColor As Range, rSumRange As Range)
'Tel al de cellen welke de kleur hebben van een aangeduide cel.
'''''''''''''''''''''''''''''''''''''''
Dim rCell As Range
Dim iCol As Integer
Dim vResult

iCol = rColor.Interior.ColorIndex

   For Each rCell In rSumRange
    If rCell.Interior.ColorIndex = iCol And rCell.Offset(, 1) < [F5] And rCell.Offset(, 2) > [F5] Then
         vResult = vResult + 1
    End If
   Next rCell

CountColor = vResult
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
Application.Range("F8").Dirty
End Sub

 

[DeCor]

HSV, bedankt.

Op de sheet "UIT" lijkt het juist te zijn, waarvoor alvast dank, maar bij sheet "IN" is het nog niet juist, dit zal wel aan mij liggen :-(
Ook moet ik telkens in de formule enteren om te updaten, kan dit automatisch?

Bekijk bijlage test voor optellen volgens kleur en datum.xls

Alvast bedankt,

Mvg,

 

[HSV]

If rCell.Interior.ColorIndex = iCol And rCell.Offset(, 1).Value < [E5] Then

En in bladmodule (om niet te hoeven enteren).

Private Sub Worksheet_Change(ByVal Target As Range)
 Application.Range("F8").Dirty
End Sub

 

[DeCor]

HSV,

Hoe moet ik dit dan integreren in de code?

Mvg,

 

[HSV]

Het gemakkelijkst is om de code te kopiëren en aan de functie een ander naam te hangen.

 

[HSV]

In één keer kan ook wel.

Function CountColor(rColor As Range, rSumRange As Range)
'Tel al de cellen welke de kleur hebben van een aangeduide cel.
'''''''''''''''''''''''''''''''''''''''
Dim rCell As Range
Dim iCol As Integer
Dim vResult

iCol = rColor.Interior.ColorIndex

   For Each rCell In rSumRange
   If rCell.Offset(, 2) = "" Then
    If rCell.Interior.ColorIndex = iCol And rCell.Offset(, 1).Value < [IN!E5] Then
         vResult = vResult + 1
    End If
    
    Else
    If rCell.Interior.ColorIndex = iCol And rCell.Offset(, 1) < [UIT!F5] And rCell.Offset(, 2) > [UIT!F5] Then
         vResult = vResult + 1
    End If
   End If
  Next rCell
 CountColor = vResult
End Function

En in moduleblad IN:

Private Sub Worksheet_Change(ByVal Target As Range)
 Application.Range("E8").Dirty
End Sub

in moduleblad UIT:

Private Sub Worksheet_Change(ByVal Target As Range)
 Application.Range("F8").Dirty
End Sub

 

[DeCor]

Bedankt HSV, ga ik morgen proberen te integreren in mijn bestandje.

Mvg,

 

[HSV]

Vandaag of morgen?

 

[DeCor]

Vandaag, is al morgen

mvg

 

[HSV]

Je bedoeld, morgen is al vandaag.

Geintje hoor.

 

[DeCor]

Nogmaals bedankt HSV,

Ik heb het proberen te integreren in mijn bestand, maar ik loop wat vast omdat de verschillende kleuren in dezelfde sheet worden opgeteld ipv 2 sheets, en ik kan de Private Sub geen 2 keer gebruiken natuurlijk.

Ik heb het voorbeeldje aangepast.

Misschien dat je daar een oplossing voor hebt?

Alvast bedankt.

Bekijk bijlage In - Uit.xls

Mvg,

 

[HSV]

In bladmodule IN.

Private Sub Worksheet_Activate()
Application.Columns(6).Dirty
End Sub

 

[DeCor]

Het werkt,

De berekening staat wel in een andere file dan de gegevens, ik moet de file wel effectief openen om deze te kunnen updaten, kan ik dit automatisch laten doen?

Het updaten gaat ook zeer traag, misschien heb ik toch nog iets niet helemaal juist gedaan met het integreren :-(

Misschien dat je dit kan zien aan de aanpassingen die ik gedaan heb?

Function CountColor(rColor As Range, rSumRange As Range)
'Tel al de cellen welke de kleur hebben van een aangeduide cel.
'''''''''''''''''''''''''''''''''''''''
Dim rCell As Range
Dim iCol As Integer
Dim vResult

iCol = rColor.Interior.ColorIndex

For Each rCell In rSumRange
If rCell.Offset(, 3) = "" Then
If rCell.Interior.ColorIndex = iCol And rCell.Offset(, 2).Value < [Voorraad!I4] Then
vResult = vResult + 1
End If

Else
If rCell.Interior.ColorIndex = iCol And rCell.Offset(, 2) < [Voorraad!I4] And rCell.Offset(, 3) > [Voorraad!I4] Then
vResult = vResult + 1
End If
End If
Next rCell
CountColor = vResult
End Function

------

Deze twee in de sheet "Voorraad" zelf:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.Range("H6:J8").Dirty
End Sub

Private Sub Worksheet_Activate()
Application.Columns(9, 10).Dirty
End Sub

---------

Alvast nogmaals bedankt HSV, ik was hier zeker niet tot gekomen en ben ik heel blij dat dit al werkt.

Mvg,

 

[DeCor]

HSV,

Ik ga het hier toch bij laten, werkt perfect (is enkel wat traag).

Nogmaals bedankt.

Mvg,