Ugeskema i excel

Ja - det skulle ikke være et større problem.

Du nævner database - i Excel eller Access?

Ved forkert løn nr. skal den bare acceptere - skulle der ikke "komme et signal"?

Du må evt. godt sende en kopi af dit ugeskema til: pb@supertekst-it.dk

Ja et eller andet sted fra skal den jo hente navne. Men da selve regnearket helst også skal kunne køre selvstændigt vil jeg da foretrække at det ligger med i regnearket, evt måske på et andet ark?

Ja dne skal bare acceptere. Der sker en rimelig stor udskiftning af folk, så hvis den ikke er helt opdateret skal folk jo stadig kunne lave sedler...

Her er et forslag:
Koden anbringes i ThisWorkbook (VBA Alt+F11)
============================================

Sub workbook_activate()
Rem Test om de faste felter er udfyldt?
    With ActiveWorkbook.Sheets(1)
        If .Range("A2") <> "" And .Range("D2") <> "" And .Range("F2") <> "" And _
            .Range("H2") And .Range("J2") <> "" And .Range("M2") <> "" Then
            Exit Sub
        Else
            Load UserForm1
            UserForm1.Show 0
        End If
    End With
End Sub

Denne kode anbringes i en userform
I userformen er der 3 tekstbokse:
- 1: Lønnr
- 2: Afd.nr.
- 3: Ugenr
2 knapper:
- 1: OK
- 2: Annuller
===================================
Private Sub CommandButton1_Click()                  'OK - udfør opslag i ark2
Dim fundetRæk
    ActiveWorkbook.Sheets(1).Activate
   
    fundetRæk = udførOpslag(Me.TextBox1)
        With ActiveWorkbook.Sheets(2)
            Range("A2") = Val(Me.TextBox1)          'lønnr. - numerisk
            Range("D2") = Val(Me.TextBox3)          'Ugenr - numerisk
            Range("F2") = Val(Me.TextBox2)          'afdeling - numerisk

Rem hent Navn fra Ark2 - hvis løn nr. er fundet
    If fundetRæk > 0 Then
            Range("M2") = .Cells(fundetRæk, 2)      'navn
    End If
   
Rem Beregn Mandag & søndag i ugen
            mandag = findDatoUge(Me.TextBox3)
            If mandag <> "" Then
                Range("H2") = mandag
                Range("J2") = DateAdd("d", 6, mandag)
            End If
        End With
   
Rem Juster kolonnebredde
    Columns.AutoFit

Rem Luk userform
    Unload UserForm1
End Sub
Private Sub CommandButton2_Click()
    Unload UserForm1
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    testOK
End Sub
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    testOK
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    testOK
End Sub
Private Sub testOK()
    With Me
        If .TextBox1 <> "" And .TextBox2 <> "" And .TextBox3 <> "" Then
            .CommandButton1.Enabled = True
            .CommandButton1.SetFocus
        Else
            .CommandButton1.Enabled = False
        End If
    End With
End Sub
Private Sub UserForm_activate()
    Me.CommandButton1.Enabled = False
End Sub
Private Function udførOpslag(lønNr)
Dim antalRæk
    With ActiveWorkbook.Sheets(2)                  'Navne
        antalRæk = ActiveCell.SpecialCells(xlLastCell).Row

Rem Overskrifter i række 1
        For ræk = 2 To antalRæk
            If .Cells(ræk, 1) = Val(lønNr) Then
                udførOpslag = ræk
                Exit Function
            End If
        Next ræk
    End With
    udførOpslag = 0
End Function
Private Function findDatoUge(unr)                  'første dato med ugenr - sidste år
Dim dato, ugeNr
    ugeNr = 0
    dato = "01-01-" + CStr(Year(Now))
    ugeNr = Format(dato, "ww", 2, 2)
   
    While ugeNr = 52
        ugeNr = Format(dato, "ww", 2, 2)
        dato = DateAdd("d", 1, dato)
    Wend
   
    While ugeNr <> Val(unr)
        ugeNr = Format(dato, "ww", 2, 2)
       
        If ugeNr = Val(unr) Then
            findDatoUge = dato
            Exit Function
        End If
        dato = DateAdd("d", 1, dato)
    Wend
    findDatoUge = ""
End Function

Hvis det er nemmere - så senden mail til: pb@supertekst-it.dk - så returnerer jeg modellen.

???

Ja undskyld ventetiden. Projektet er imidlertid gået i vasken/stoppet så har aldrig afprøvet din kode. Læg gerne et svar...

- Rasmus!

Ok - du får et svar.