Tæl.Hvis

Dur ikke, her er en brugerdefineret funktion som bak lavede engang.

Function ColorCount(rRange As Range, rColor As Range) As Variant
Dim rCell As Range
Dim dCount As Double
C = rColor.Interior.ColorIndex
dCount = 0
    Application.Volatile
    For Each rCell In rRange
    If rCell.Interior.ColorIndex = rColor.Interior.ColorIndex Then
            dCount = dCount + 1
        End If
    Next rCell
    ColorCount = dCount & " stk."
 
End Function

Som du jo nok har regnet ud, skal det bruges i den turnusplan du hjalp med tidligere.

Det ville være fint hvis man kunne vælge person i et rullegardin, og indtaste for hvilken periode man ønsker oplyst. Evt. i 4 celler, som jeg gør når jeg printer.

De 200 point fra før, var heller ikke svært tjente vel?, så kan jeg købe lidt mere hjælp for dem. Hvis ja kan jeg sende filen igen, med de ændringer jeg har lavet.

På forhånd tak.

Du for selvfølgelig også de 30 point her, hvis du hjælper en gang til.

Du må gerne sende den igen, husk at skrive dine ønsker.

Hvor ligger det du kalder navne er det 1 til 10

Ja.

Numrene 1-10, er pladserne hvor mine kollegaers navne kommer til at stå.

er sendt retur

Et enkelt problem.

Når jeg beskytter ark "Statistik" og starter søgning, stopper den og markere følgende linie i debuggeren.

Sheets("Statistik").Range("C20") = dCount

C20 er en af de beskyttede celler.

Skift din kode i Arket Statistik ud med denne.

Private Sub Søg_Click()

If Range("D6") = "" Or Range("D7") = "" Or Range("F6") = "" Or Range("F7") = "" Then
  MsgBox "Alle felter skal udfyldes " & Chr(13) & _
  " Tast venligst om"
  Range("D6").Select
Exit Sub
End If


If Range("F6") > Range("F7") Then
    MsgBox "Start årstal er større end slut årstal" & Chr(13) & _
    " Tast venligst om"
  Range("F6").Select
Exit Sub
End If


If Range("D6") > Range("D7") And Range("F6") = Range("F7") Then
    MsgBox "Startmåned er større end slutmåned" & Chr(13) & _
    " Tast venligst om"
  Range("D6").Select
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Unprotect
Call FindNavne
Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("A1").Select
End Sub

Hej Kabbak

Så virker det.

Hvis jeg skal ændre antallet af personer i turnusplanen, skal der så mere til end følgende kode(tilpasset selvfølgelig).
If Range("F6") = A Then
Range(Cells(R1, 7), Cells(R2, 7)).Select
GoTo TÆL
End If

Hvis jeg ønsker og søge oplysninger om flere farver, skal der så mere til end følgende kode(tilpasset selvfølgelig), med tilhørende celle med den farve man søger efter.
dCount = 0
    Application.Volatile
    For Each rCell In Selection
    If rCell.Interior.ColorIndex = Sheets("Statistik").Range("C14").Interior.ColorIndex Then
            dCount = dCount + 1
        End If
    Next rCell
    Sheets("Statistik").Range("C14") = dCount

For din indsats, mente jeg ikke 30 point var nok, så du får 100 istedet.
Endnu engang tak for hjælpen.

ja, såvidt jeg husker er det de 2 steder du skal tilføje ved flere personer.

nb.Programeringen havde været lettere hvis cellerne med navne ikke var flettet.

Tak for point