hente data fra et regneark der ligger på et andet drev

Det kan du sagtens

Men hvad ønsker du? et opslag? eller en sum pr medarbejder?

Det letteste er at lave summen i dit kildeark, kopiere derefter cellen
indsæt speciel i det ark du har på din pc, og vælg indsæt kæde

Ja det er rigtigt nok men jeg vil gerne have de enkelte datoer med over hvor vedkommende har været på arbejdet

så det jeg egenligt gerne vil er at hvis jeg skriver et lønnr i et formel felt fyldes dataerne ind i regnearket med f.eks navn i lønnr i kolonne a og derefter lønnr. og så de enkelte datoer han har været på arbejde

Det kræver noget VBA programering inden du kan få dette til at virke optimalt.
Der melder jeg pas, jeg springer fra.

VBA-programmering kan jeg godt klare - men

- det ville nok være en fordel at de de 2 nævnte regneark - evt. en model, der illustrere opbygningen. Kan i givet fald sendes til: pb@supertekst-it.dk

- og så synes jeg du skal give accept på det spørgsmål, som du har fået svar på pr. 22/12-07

Hej det lyder dejligt hvis du kan hjælpe mig og jeg skal prøve at ilustrerede det i en mail til dig
og hvis der er noget jeg ikke har givet accept er jeg da ked af og skal nok rette det hvis jeg kan

http://www.eksperten.dk/spm/744317

Noget nyt??

Hej Supertekst.
Det virkede fint, men jeg har desvære været langtids syg og du må derfor meget undskylde at du ikke har fået hverken tak eller point
jeg håber at jeg kan rette op på det igen.

Ok - det vigtigste er trods alt helbredet...

Koden i Userform:

Const systemArkNavn = "System"
Const kontrolArkNavn = "Kontrol"

Dim serverDrevFil, serverXLS
Dim sysArk As Worksheet, kontrolArk As Worksheet
Dim kontrolRæk
Private Sub CommandButton1_Click()                  'OK - henter data vedr. valgte medarb.
    For ix = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(ix) = True Then
            hentMedarbejderDataFraServer Me.ListBox1.List(ix, 2)
        End If
    Next ix
   
Rem ophæv markerede medarbejdere efter opdatering
    Me.ListBox1.ListIndex = -1
End Sub
Private Sub CommandButton2_Click()                  'Luk
    kontrolArk.Activate
    lukServerXls
   
    Unload UserForm1
End Sub
Private Sub userform_terminate()                    'X-knap
    CommandButton2_Click
End Sub
Private Sub UserForm_activate()
    Application.ScreenUpdating = False
    opsætArk
    tilpasListbox
   
    serverDrevFil = hentServerDrevFil
    visMedarbejderDataFraServer
    kontrolRæk = findledigKontrolRække
End Sub
Private Sub opsætArk()
    With ActiveWorkbook
        Set sysArk = .Sheets(systemArkNavn)
        Set kontrolArk = .Sheets(kontrolArkNavn)
    End With
End Sub
Private Sub tilpasListbox()
    With Me.ListBox1
        .ColumnCount = 3
        .ColumnWidths = "50;50,50"
    End With
End Sub
Private Function hentServerDrevFil()
    hentServerDrevFil = sysArk.Range("B1")
End Function
Private Sub visMedarbejderDataFraServer()
On Error GoTo fejl

    Set serverXLS = CreateObject("Excel.Application")
    With serverXLS
        .Workbooks.Open serverDrevFil
       
        For ræk = 2 To 65000
            If .Cells(ræk, 1) <> "" Then
                navn = .Sheets(1).Cells(ræk, 1)
                init = .Sheets(1).Cells(ræk, 2)
                lønnr = .Sheets(1).Cells(ræk, 3)
Rem overfør til ListBox1
                Me.ListBox1.AddItem navn
                Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = init
                Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = lønnr
            Else
                Exit For
            End If
        Next ræk
    End With
    Exit Sub
   
fejl:
    MsgBox ("Fejl erkendt - kontakt udvikler")
    lukServerXls
   
End Sub
Private Function findledigKontrolRække()
    kontrolArk.Select
    findledigKontrolRække = ActiveCell.SpecialCells(xlLastCell).Row + 1
End Function
Private Sub hentMedarbejderDataFraServer(lønnr)
Dim ark, mRæk
    With serverXLS
        For Each ark In .ActiveWorkbook.Sheets
Rem test om arknavn begynder med "uge"
                If LCase(Left(ark.Name, 3)) = "uge" Then
                    ark.Select
Rem find medarbejderens række på server-filen
                    mRæk = SøgMedarbejderServerFil(lønnr)
                    If mRæk > 0 Then
                        overførData mRæk, lønnr
                    End If
                End If
        Next ark
    End With
End Sub
Private Function SøgMedarbejderServerFil(lønnr)
    With serverXLS.Range("C2:C65000")
        Set c = .Find(lønnr, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            SøgMedarbejderServerFil = c.Row
            Exit Function
        Else
            SøgMedarbejderServerFil = 0
        End If
    End With
End Function
Private Sub overførData(mRæk, lønnr)                      'overfør data til kontrolark
Dim kRæk, Kolonne
Rem test om medarbejder allerede findes i kontrolark
    kRæk = søgMedarbejderKontrolArk(lønnr)
   
Rem medarbejder findes ikke i kontrolark - overfør derfor ID-data
    If kRæk = 0 Then
        kRæk = kontrolRæk
        Kolonne = 4                                        '1. kolonne til dato+indhold
       
        With serverXLS
            kontrolArk.Cells(kontrolRæk, 1) = .Cells(mRæk, 1)
            kontrolArk.Cells(kontrolRæk, 2) = .Cells(mRæk, 2)
            kontrolArk.Cells(kontrolRæk, 3) = .Cells(mRæk, 3)
        End With
        kontrolRæk = kontrolRæk + 2
    Else
        Kolonne = findLedigeKolonne(kRæk)                  'find første kolonne bestående medarbejder i kontrolArk
    End If
   
    If Kolonne > 0 Then
        overførUdfyldteDatoer kRæk, Kolonne, mRæk
    End If
End Sub
Private Function søgMedarbejderKontrolArk(lønnr)
    With kontrolArk.Range("C2:C65000")
        Set c = .Find(lønnr, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            søgMedarbejderKontrolArk = c.Row
            Exit Function
        Else
            søgMedarbejderKontrolArk = 0
        End If
    End With

End Function
Private Function findLedigeKolonne(kRæk)
    For kol = 4 To kontrolArk.Columns.Count
        If Cells(kRæk, kol) = "" Then
            findLedigeKolonne = kol
            Exit Function
        End If
    Next kol
Rem Ingen ledeig kolonne fundet
    findledigkolonne = 0
End Function
Private Sub overførUdfyldteDatoer(kRæk, Kolonne, mRæk)      'fra Serverfil -> kontrolArk
    With serverXLS
        For k = 4 To 256
            datoværdi = .Cells(mRæk, k)
            dato = .Cells(1, k)
            If datoværdi <> "" Then
                kontrolArk.Cells(kRæk, Kolonne) = dato
                kontrolArk.Cells(kRæk + 1, Kolonne) = datoværdi
                Kolonne = Kolonne + 1
            End If
        Next k
    End With
End Sub
Private Sub lukServerXls()
On Error Resume Next
    serverXLS.Application.Quit
    Set serverXLS = Nothing
End Sub