Bepaalde waardes optellen in cellen met VBA

[adile]

Goedenavond,

Ik heb een bestand waarin ik namen heb staan in verschillende werkbladen in kolom G.
de namen waarvan er meer dan 1 zijn tel ik op in een apart werkblad. hiervoor heb ik een VBA formule aan de knop tellen vastgemaakt.

met deze formule worden lege cellen en de cellen met de waardes "onbekend" en "N.V.T." ook opgeteld.
deze 3 waardes wil ik met een wijziging in de bestaande formule weg filteren dat dit niet gedaan wordt.

Private Sub CommandButton1_Click()

    Dim ws      As Worksheet
    
    Dim var     As Variant
    Dim dic     As Object
    
    Dim x       As Long
    Dim y       As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For Each ws In Sheets(Array("Week 1", "Week 2", "Week 3", "Week 4", "Week 5"))
        With ws
            y = .Cells(.Rows.Count, 7).End(xlUp).Row
            If y > 4 Then
                For x = 5 To y
                    If dic.exists(.Cells(x, 7).Value) Then
                        dic(.Cells(x, 7).Value) = dic(.Cells(x, 7).Value) + 1
                    Else
                        dic(.Cells(x, 7).Value) = 1
                    End If
                Next x
            End If
        End With
    Next ws
    
    With Sheets("Eindlijst")
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        If y > 3 Then .Cells(4, 2).Resize(y, 2).ClearContents
        
        x = 4
        For Each var In dic
            If dic(var) > 1 Then
                .Cells(x, 2).Value = var
                .Cells(x, 3).Value = dic(var)
                x = x + 1
            End If
        Next var
        
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        If y > 3 Then
            .Cells(3, 2).Resize(y - 2, 2).Sort key1:=.Cells(3, 3), order1:=xlDescending, Header:=xlYes
        End If
        
    End With
    
    Set dic = Nothing
    
End Sub

heeft iemand een idee wat er aan de formule aangepast moet worden?
Alvast bedankt.

Adile

 

[Warme bakkertje]

Private Sub CommandButton1_Click()

    Dim ws      As Worksheet
    
    Dim var     As Variant
    Dim dic     As Object
    
    Dim x       As Long
    Dim y       As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For Each ws In Sheets(Array("Week 1", "Week 2", "Week 3", "Week 4", "Week 5"))
        With ws
            y = .Cells(.Rows.Count, 7).End(xlUp).Row
            If y > 4 Then
                For x = 5 To y
                    [COLOR="#FF0000"]If .Cells(x, 7).Value <> "Onbekend" And .Cells(x, 7).Value <> "N.V.T." Then[/COLOR]
                        If dic.exists(.Cells(x, 7).Value) Then
                            dic(.Cells(x, 7).Value) = dic(.Cells(x, 7).Value) + 1
                        Else
                            dic(.Cells(x, 7).Value) = 1
                        End If
                    [COLOR="#FF0000"]End If[/COLOR]
                Next x
            End If
        End With
    Next ws
    
    With Sheets("Eindlijst")
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        If y > 3 Then .Cells(4, 2).Resize(y, 2).ClearContents
        
        x = 4
        For Each var In dic
            If dic(var) > 1 Then
                .Cells(x, 2).Value = var
                .Cells(x, 3).Value = dic(var)
                x = x + 1
            End If
        Next var
        
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        If y > 3 Then
            .Cells(3, 2).Resize(y - 2, 2).Sort key1:=.Cells(3, 3), order1:=xlDescending, Header:=xlYes
        End If
        
    End With
    
    Set dic = Nothing
    
End Sub

 

[adile]

bestandje vergeten toe te voegen.

Adile

 

[adile]

Rudi,

Dat is hem man, ik heb de "" nog toegevoegd nu worden de lege cellen ook niet meer opgeteld.

Thanks man hier ben ik erg mee geholpen. :thumb:

Adile