Booking ark - maks 3 behandlinger pr. periode

Stå i B5

Gå ind i Datavalidering >> Brugerdefineret
skriv:

=tæl.hvis($B$5:$I$10;B5)<=3

Markér området B5:I10
gå ind i Datavalidering,
tilføj til alle celler

eller:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim navn As String, antal As Integer
    If Target.Address >= "$B$5" And Target.Address <= "$I$10" Then
        navn = Target
       
        If navn <> "" Then
            antal = tælAntal(navn)
       
            If antal > 3 Then
                MsgBox navn & " forekommer mere end 3 gange"
            End If
        End If
    End If
End Sub
Private Function tælAntal(navn)
Dim antal As Integer
    anal = 0
    For Each cc In Range("B5:I10").Cells
        If navn = cc.Text Then
            antal = antal + 1
        End If
    Next cc
   
    tælAntal = antal
End Function

Stå i B5

Gå ind i Datavalidering >> Brugerdefineret
skriv:

=tæl.hvis($B$5:$I$10;B5)<=3

Markér området B5:I10
gå ind i Datavalidering,
tilføj til alle celler

Hej igen

Tak for gode svar

Mht. datavalidering bruger jeg det til en navneliste i forvejen, så den går ikke.

VBA'en giver mig fejl når jeg sletter indholdet i en celle, og man kan godt sætte sit navn på over 3 gange, da man blot får en advarsel og ikke bliver stoppet, kan måske løses ved at slette den aktive celle når man får advarslen?

Mvh Bo

Ok - ser på det igen..

Rem Får ikke fejl ved sletning af en celle

Private Sub Worksheet_Change(ByVal Target As Range)
Dim navn As String, antal As Integer
    If Target.Address >= "$B$5" And Target.Address <= "$I$10" Then
        navn = Target
       
        If navn <> "" Then
            antal = tælAntal(navn)
       
            If antal > 3 Then
                Target.ClearContents                'tilføjelse
                MsgBox navn & " forekommer mere end 3 gange"
            End If
        End If
    End If
End Sub
Private Function tælAntal(navn)
Dim antal As Integer
    anal = 0
    For Each cc In Range("B5:I10").Cells
        If navn = cc.Text Then
            antal = antal + 1
        End If
    Next cc
   
    tælAntal = antal
End Function

Super, tak for hjælpen :)

Venligst smid svar til pointgivning:)

Selv tak - du får et svar