Userform e.l.

Se: http://www.eksperten.dk/spm/799160

Det skal helst være via vba

Hvis du sender en kopi af de to nævnte filer (timer.xls & data.xls) så skal jeg forsøge - selvom tiden er knap.

Hvis du har glemt adressen: pb@supertekst-it.dk

Da vi andre også kan blive klogere, er det en god ide med løsningen her på siden.

Jeg er sikker på at Supertekst poster den her på siden når opgaven er løst. Det plejer han at gøre :-)

kommer......

Følgende kode er indlagt i Userform i filen Timer.xls:

Const sti = "C:\Documents and Settings\pb\Skrivebord\1810Mirac\"    'TILPASSES
Dim dataXls, ak
Private Sub CommandButton1_Click()                      'OK
    behandlMedarbejder
End Sub
Private Sub CommandButton2_Click()                      'annuller
    Unload UserForm1
End Sub
Private Sub ListBox1_Click()                            'medarbejder valgt
    Me.lab_MedarbejderNr.Caption = Me.ListBox2.List(Me.ListBox1.ListIndex)
    ak = Me.ListBox3.List(Me.ListBox1.ListIndex)
    Me.Tb_adgangskode.SetFocus
End Sub
Private Sub xxTb_adgangskode_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If ak <> "" Then
        If Me.Tb_adgangskode = ak Then
            Me.Tb_adgangskode = ""
            ak = ""
        Else
            Me.CommandButton1.Enabled = False
            Me.Tb_adgangskode = ""
        End If
    Else
        MsgBox ("Adgangskode findes ikke")
        Me.Tb_adgangskode = ""
    End If
End Sub
Private Sub UserForm_activate()
    skjulAlleArkfaner
    hentMedarbejderNavne
End Sub
Private Sub behandlMedarbejder()
Rem check om OK
    If ak <> "" Then
        If Me.Tb_adgangskode = ak Then
            Me.Tb_adgangskode = ""
            ak = ""
Rem OK
            If findesMedarbejderArk(Me.lab_MedarbejderNr) = False Then
                opretArk Me.lab_MedarbejderNr
            End If
           
            visArkMedarbejder Me.lab_MedarbejderNr
           
        Rem medarbejderNr + navn vises i "label" i userform5
            UserForm5.Label1 = Me.lab_MedarbejderNr + " " + Me.ListBox1
            Load UserForm5
            UserForm5.Show
           
            Me.ListBox1.ListIndex = -1
            skjulAlleArkfaner
        Else
            MsgBox ("Adgangskode ikke korrekt!")
            Me.Tb_adgangskode = ""
        End If
    Else
        MsgBox ("Adgangskode ikke udfyldt!")
    End If
End Sub
Private Sub opretArk(mNr)
    With ActiveWorkbook
        .Sheets("Kopi").Select
        .Sheets("Kopi").Copy After:=Sheets(1)
        .Sheets("Kopi (2)").Select
        .Sheets("Kopi (2)").Name = mNr
    End With
End Sub
Private Sub visArkMedarbejder(mNr)
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name = mNr Then
            ark.Visible = True
        End If
    Next
End Sub
Private Function findesMedarbejderArk(mNr)
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name = mNr Then
            findesMedarbejderArk = True
            Exit Function
        End If
    Next
    findesMedarbejderArk = False
End Function
Private Sub hentMedarbejderNavne()
Dim ræk
On Error GoTo lukDataXls

    Me.ListBox1.Clear
    Me.ListBox2.Clear
    Me.ListBox3.Clear
   
    Set dataXls = CreateObject("Excel.application")
    With dataXls
        .Workbooks.Open sti + "data.xls"
        .ActiveWorkbook.Sheets("medarb").Activate
   
        With dataXls.ActiveSheet
            For ræk = 11 To 65000
                If IsEmpty(.Cells(ræk, 1)) = True Then
                    Exit For
                Else
                    Me.ListBox1.AddItem .Cells(ræk, 2)      'medarbejderNavn
                    Me.ListBox2.AddItem .Cells(ræk, 1)      'medarbejderNr i skjult liste
                    Me.ListBox3.AddItem .Cells(ræk, 10)    'ak
                End If
            Next ræk
        End With
    End With
   
lukDataXls:
    dataXls.Quit
    Set dataXls = Nothing
End Sub
Private Sub skjulAlleArkfaner()
    For Each ark In ActiveWorkbook.Sheets
        If LCase(ark.Name) <> "kopi" Then
            ark.Visible = False
        End If
    Next
End Sub

Takker for hjælpen