VBA+kopiere ark til en anden Excel-fil

Ja - det kan man godt.
Hvor i den kaldende fil, skal de kopierede ark indsættes?

De skal indsættes forrest

Const stiData = "C:\Documents and Settings\pb\Skrivebord\1803KopierArk\data.xls"    'Tilpasses
Dim xls As Object
Sub kopierData()
    Set xls = CreateObject("Excel.Application")
    With xls
        .Workbooks.Open stiData
       
        For ark = 1 To 4
            .ActiveWorkbook.Sheets(ark).Activate
            .Cells.Copy
            ActiveWorkbook.Sheets.Add before:=ActiveWorkbook.Sheets(ark)
            ActiveSheet.Paste Destination:=Worksheets(ark).Range("A1")
        Next ark
    End With
   
    xls.Quit
    Set xls = Nothing
End Sub

PS: mangler lidt til kode til at slette udklipsholder - vender tilbage med denne

Skal der tilrettes i disse to linier ?

ActiveWorkbook.Sheets.Add before:=ActiveWorkbook.Sheets(ark)
ActiveSheet.Paste Destination:=Worksheets(ark).Range("A1")

Hvor skal koden placeres hvis det er det første den skal gøre når man åbner Excel-filen ?

Nej -

Har placeret det i et Modul..

Og endnu et dumt spørgsmål...

Hvordan kalder jeg så denne makro ved workbook_open når den ligger i et modul

module1.kopierData

eller flytte koden til ThisWorkbook i.f.m Workbook_activate()

Perfekt

Der er som du selv nævner lige meddelelsen om udklipsholderen.
Kan de kopierede ark beholde deres navngivning fra kildefilen ?

Og kan, hvis man kører makroen igen, man få den til at overskrive de ark og ikke bare indsætte 4 nye ark.

Godt...

Har endnu ikke fundet midlet - men prøver...
Ja - det kan de godt
Ja - så vil det nemlig ideelt, at ArkNavne overføres - og så slette dem, hvis de eksisterer i forvejen.

Const stiData = "C:\Documents and Settings\pb\Skrivebord\1803KopierArk_MiRa\data.xls"    'Tilpasses
Dim xls As Object
Sub kopierData()
    Set xls = CreateObject("Excel.Application")
    With xls
        .Workbooks.Open stiData
       
        For ark = 1 To 4
            .ActiveWorkbook.Sheets(ark).Activate
            .Cells.Copy
           
            Application.DisplayAlerts = False
            testOmArkFindes .ActiveWorkbook.Sheets(ark).Name
           
            ActiveWorkbook.Sheets.Add before:=ActiveWorkbook.Sheets(ark)
            ActiveSheet.Paste Destination:=Worksheets(ark).Range("A1")
            ActiveSheet.Name = .ActiveWorkbook.Sheets(ark).Name
        Next ark
    End With
   
    xls.Application.DisplayAlerts = False
    xls.Quit
    Set xls = Nothing
   
    Application.DisplayAlerts = True
End Sub
Private Sub testOmArkFindes(ark)
    For Each a In ActiveWorkbook.Sheets
        If a.Name = ark Then
            a.Delete
        End If
    Next a
End Sub

Det virker sådan set godt.

Men hvorfor bliver min datafil (data.xls) skrivebeskyttet ? Den vedbliver at være skrivebeskyttet også efter jeg lukker Excel.

Her er min kode i ThisWorkbook:

Const stiData = "C:\Rødvig\Data.xls"    'Tilpasses
Dim xls As Object
Private Sub Workbook_Open()
    Set xls = CreateObject("Excel.Application")
    With xls
        .Workbooks.Open stiData
       
        For ark = 1 To 4
            .ActiveWorkbook.Sheets(ark).Activate
            .Cells.Copy
           
            Application.DisplayAlerts = False
            testOmArkFindes .ActiveWorkbook.Sheets(ark).Name
           
            ActiveWorkbook.Sheets.Add before:=ActiveWorkbook.Sheets(ark)
            ActiveSheet.Paste Destination:=Worksheets(ark).Range("A1")
            ActiveSheet.Name = .ActiveWorkbook.Sheets(ark).Name
            ActiveSheet.Visible = False
        Next ark
    End With
   
    xls.Application.DisplayAlerts = False
    xls.Quit
    Set xls = Nothing
    If Right(LCase(ActiveWorkbook.Name), 3) <> "xls" Then
        Load UserForm4
        UserForm4.Show
    End If
    Application.DisplayAlerts = True
End Sub
Private Sub testOmArkFindes(ark)
    For Each a In ActiveWorkbook.Sheets
        If a.Name = ark Then
            a.Delete
        End If
    Next a
End Sub

Her er min kode i Userform4:

Rem Version 5
Rem =========
Const DataSti = "C:\Rødvig\Data.xls"      'tilpasses
Const gemSomSti = "C:\Rødvig\Tilbud\"          'tilpasses
Dim rækIArk, aktuelleRæk
Dim dataarkXLS As Object, kXLS As Object, passFlag As Boolean

Private Sub udførGem()
Dim sti As String, gemMappe As String, uMappe As String

Rem check drev
    On Error GoTo sti_Fejl

    sti = gemSomSti
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If
   

Rem KundeMappe Ok - gem filen
    On Error GoTo fejlGemSti
    ActiveWorkbook.SaveAs sti + "Tilbud " + f_projekt + " " + Me.f_kundeNr + ".xls"

Rem Luk userform
    CommandButton2_Click                            'kan fjernes, hvis lukning ikke ønskes
    Exit Sub


fejlGemSti:
    MsgBox ("Fejl i GemSti - sandsynligvis illegalt tegn i årstal")
    Exit Sub
   
sti_Fejl:
    MsgBox ("Fejl i en sti-angivelse")
End Sub


Private Sub f_kundeNr_Enter()
    Me.f_kundeNavn = ""
     
End Sub
Private Sub f_kundeNr_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If passFlag = False Then
        passFlag = True
        If Me.f_kundeNr <> "" And IsNumeric(Me.f_kundeNr) = True Then
            Me.f_kundeNavn = søgKunde(Val(Me.f_kundeNr))
            Me.f_adresse = søgKundeA(Val(Me.f_kundeNr))
            Me.f_postnr = søgKundeP(Val(Me.f_kundeNr))
            Me.f_by = søgKundeB(Val(Me.f_kundeNr))
       
            If Me.f_kundeNavn <> "" Then
                    Me.f_kundeNr.SetFocus
            End If
           
            kXLS.Quit
            Set kXLS = Nothing
        End If
        passFlag = False
    End If
End Sub
Private Sub CommandButton2_Click()          'Annuller
    Unload UserForm4
End Sub

Private Function søgKunde(kNr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = kNr Then
                søgKunde = .Cells(r, 2)
                Exit Function
            End If
        Next r
    End With
    søgKunde = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function
Private Function søgKundeA(kNr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = kNr Then
                søgKundeA = .Cells(r, 3)
                Exit Function
            End If
        Next r
    End With
    søgKundeA = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function
Private Function søgKundeP(kNr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = kNr Then
                søgKundeP = .Cells(r, 4)
                Exit Function
            End If
        Next r
    End With
    søgKundeP = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function
Private Function søgKundeB(kNr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = kNr Then
                søgKundeB = .Cells(r, 5)
                Exit Function
            End If
        Next r
    End With
    søgKundeB = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function
Private Function findGemMappe(sti, kNr)
Rem Søger efter mappe med navnet: Kundenr+BLANK i begyndelsen af MappeNavnet
    Dim fs, f, f1, fc, s, xKnr
    kNr = CStr(Val(kNr))                            'fjerner foranstillede nuller
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sti)
    Set fc = f.SubFolders
    For Each f1 In fc
        If InStr(f1.Name, kNr + " ") = 1 Or InStr(f1.Name, kNr) = 1 Then
            findGemMappe = f1.Name                  'Fulde mappeNavn returneres..
            Exit Function
        End If
    Next
    findGemMappe = ""
End Function
Private Sub UserForm_activate()
    indlæsprojekt
    Me.f_kundeNr.SetFocus
End Sub
Private Sub indlæsprojekt()
    On Error GoTo fejlprojektSti
   
    Set dataarkXLS = CreateObject("Excel.application")
    With dataarkXLS
        .Workbooks.Open DataSti
        .Sheets(3).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 5 To Max
            Me.f_projekt.AddItem .Cells(r, 1)
        Next r
    End With
   
    dataarkXLS.Quit
    Set dataarkXLS = Nothing
    Exit Sub

fejlprojektSti:
    MsgBox ("Fejl i sti t/projekt.xls")
End Sub

Private Sub CommandButton1_Click()
     
    If Me.f_kundeNr.Value <> "" And _
    Me.f_projekt.Value <> "" Then
               
                    OpdaterIArk
        udførGem
    Else
        MsgBox ("Alle felter skal udfyldes")
    End If
End Sub




Private Sub OpdaterIArk()

        Sheets("Tilbud").Activate
        Cells(7, 1) = Me.f_kundeNr.Value
        Cells(17, 2) = Me.f_projekt.Value
       
       
     
       
End Sub

Et bonusspørgsmål

I stedet for at den sletter arkene hvis de findes i forvejen. Kan den så ikke overskrive dem.

Grunden er at jeg har foruddefinerede områder i mit data-ark som bruges i formler i destinationsarket. Disse følger ikke med. Så har jeg prøvet at foruddefinere områder i destinationsarket (dvs. oprette de 4 ark på fohånd), men da de bliver slettet forsvinder mit navngivne/foruddefinerede område ?

Giver det mening ?

Vender tilbage - er optaget af kunde-opgave.....

Andre der måske har et bud, da Supertekst desværre er optaget. Jeg ville meget gerne have løst dette i weekenden.

Nogen som har mod på det ?

Hej mira96ac
Så blev der lidt luft....

Årsagen til låsning af "kilde" er, hvis koden afbrydes og disse to linier ikke udføres:
    xls.Quit
    Set xls = Nothing

Sker det genstart.....



Her er koden, der ikke kopiere - men overføre udfylde celler fra kilde til modtager:


Const stiData = "C:\Documents and Settings\pb\Skrivebord\1803KopierArk_MiRa\data.xls"    'Tilpasses
Dim xls As Object
Sub kopierData()
Dim dataR, dataK
    Set xls = CreateObject("Excel.Application")
    With xls
        .Workbooks.Open stiData
        .Visible = True
        dataR = .ActiveCell.SpecialCells(xlLastCell).Row
        dataK = ActiveCell.SpecialCells(xlLastCell).Column
       
Rem Overføre alle celler fra "kilden", der er udfyldt i tilsvarende ark/"modtager"
        For ark = 1 To 4
            .ActiveWorkbook.Sheets(ark).Activate
            For r = 1 To dataR
                For k = 1 To dataK
                    If .Cells(r, k) <> "" Then
                        ActiveWorkbook.Sheets(ark).Cells(r, k) = .Cells(r, k)
                    End If
                Next k
            Next r
        Next ark
    End With
   
    xls.Quit
    Set xls = Nothing
End Sub

Hej  Supertekst.  Du er en travlt mand. Men jeg holder dig selvfølgelig også rigeligt beskæftiget med alle mine spørgsmål.

Hvornår afbrydes koden ???

Jeg tester lige den anden. Men dvs. at alle 4 ark skal være oprettet i destinationsfilen og så overskrives calalerne bare når jeg aktiverer makroen ? Arkene slettes ikke ?

Overfører den så også callenavngivningen ?
Eller bibeholder den dem i destinationarket hvis jeg har navngivet områder der ?

Jeg har nemlig en datavalidering i et 5'te ark i destinationsarket som henter data fra de 4 ark som overføres.

Jeg synes ikke den virker...

I destinationsarket aktiverer de alle 4 ark lige efter hinanden, men den kopierer ikke kildearkene eller kildearket celler over

Måske jeg nu har luret lidt af problemet.

Den skal også tilføje nye rækker/kolonner fra kildearkene til destinationsarkene.

Den gør den ikke lige nu vel ?

Den ovefører (skulle) alle celler fra et kildeark til destinationsark...

Jeg kan ikke få den til det...

Jeg har tilføjet en ny linie i den ene ark i kildefilen for at teste det.

Den kommer ikke med over i det selvsamme ark i destinationsfilen/arket.

et bud far mig:

Sub kopierData()
    Dim Data As Variant, Ark As Integer
    Application.ScreenUpdating = False
    Workbooks.Open "C:\Data\data.xls"    'Tilpasses, husk at rette filnavnet i de andre linier også.
    For Ark = 1 To 4
        Workbooks("data.xls").Activate ' husk at rette filnavnet i de andre linier også.
        Data = ActiveWorkbook.Sheets(Ark).UsedRange
        ThisWorkbook.Activate
        Sheets(Ark).Activate
        Cells.ClearContents
        Range(Cells(1, 1), Cells(UBound(Data, 1), UBound(Data, 2))) = Data
    Next Ark
    Workbooks("data.xls").Close (False) ' husk at rette filnavnet i de andre linier også.
    Application.ScreenUpdating = True
End Sub

Bemærk, hverken formater eller formler, kommer med over, kun værdier.

Arkene skal være oprettet på forhånd.
Du ville have de 4 ark skjuli, ser jeg, det er med her.

Sub kopierData()
    Dim Data As Variant, Ark As Integer
    Application.ScreenUpdating = False
    Workbooks.Open "C:\Data\data.xls"    'Tilpasses, husk at rette filnavnet i de andre linier også.
    For Ark = 1 To 4
        Workbooks("data.xls").Activate    ' husk at rette filnavnet i de andre linier også.
        Data = ActiveWorkbook.Sheets(Ark).UsedRange
        ThisWorkbook.Activate
        Sheets(Ark).Activate
        Cells.ClearContents
        Range(Cells(1, 1), Cells(UBound(Data, 1), UBound(Data, 2))) = Data
        Sheets(Ark).Visible = False
    Next Ark
    Workbooks("data.xls").Close (False)    ' husk at rette filnavnet i de andre linier også.
    Application.ScreenUpdating = True
End Sub

Hej kabbak

Umiddelbart ser det ikke ud til at den opdaterer arkene i destinationsfilen. Den skjuler dem fint, men den tager ikke dataene fra kildefilen med over.

Til Supertekst

Jeg har delvist fået din makro til at virke. Men jeg kan se på skærmen at den kører alle arkene igennem i destinationsfilen og at den opdaterer dem. Men det sidste den gør er at springe til ark1 og "fjerne" opdateringen igen ????? Således at der altså ikke er ændret noget.

Ok så prøver vi med navnene som du ser på fanerne, ret dem selv til.


Sub kopierData()
    Dim Data As Variant, ArkNavn As Variant, Ark As Integer
    ArkNavn = Array("Ark1", "Ark2", "Ark3", "Ark4") ' ret disse navne til at passe med dine arknavne.
    ' de skal være ens i begge mapper
    Application.ScreenUpdating = False
    Workbooks.Open "C:\Data\data.xls"    'Tilpasses, husk at rette filnavnet i de andre linier også.
    For Ark = 0 To 3
        Workbooks("data.xls").Activate    ' husk at rette filnavnet i de andre linier også.
        Data = ActiveWorkbook.Sheets(ArkNavn(Ark)).UsedRange
        ThisWorkbook.Activate
        Sheets(ArkNavn(Ark)).Activate
        Cells.ClearContents
        Range(Cells(1, 1), Cells(UBound(Data, 1), UBound(Data, 2))) = Data
        Sheets(ArkNavn(Ark)).Visible = False
    Next Ark
    Workbooks("data.xls").Close (False)    ' husk at rette filnavnet i de andre linier også.
    Application.ScreenUpdating = True
End Sub

Til kabbak

Min hjerne fungerer ikke optimalt.

Det virker faktisk når man nu gør det ordentlig.

"Det virker faktisk når man nu gør det ordentlig."

hvad gjorde du ikke ordentlig ??
Var Supertekst kode så også i orden ??

Jeg har dog stadig det problem med at den skrivebeskytter mit dataark/kildeark

Jeg har ikke helt forstået hvorfor.

Lige nu bruger jeg kabbak's makro.

"Jeg har dog stadig det problem med at den skrivebeskytter mit dataark/kildeark"

den data.xls, jeg bruger bliver ikke skrivebeskyttet, er det ikke fordi du har sat den op til at åbne skrivebeskyttet, engang du gemte den. ??

Min fejl var at kalde det forkerte kildeark. Jeg stavede ikke ordentligt.

Den skrivebeskytter (eller siger at "Data.xls er allerede åben"), men kun nogle gange, og jeg har ikke fundet systematikken endnu.

Men lige nu fungerer det fint.

Må man stille et par ekstra spørgsmål (man kan jo aldrig få nok)
Jeg åbner også gerne et nyt spørgsmål

1. Kan man lave et lopslag som slår værdien til venstre for søgeværdien op ?

Og noget helt andet:

2. Prøv at se denne løsning (fra Supertekst faktisk). Man kan taste linienummer i funktionen "visaktuellerække" og så viser den værdierne i userformen for den linie i regnearket. Men kan man ændre det så den slå værdierne i kolonne A op og viser dem i userformen:

Const grøn = &HC0FFC0
Const gul = &H80FFFF
Dim rækIArk, aktuelleRæk
Private Sub f_afslut_Click()
    ClearFelter
    Unload UserForm
End Sub
Private Sub f_clear_Click()
    ClearFelter
    aktuelleRæk = rækIArk
    visAktuelleRække
End Sub
Private Sub f_gem_Click()
Rem test om alle felter er udfyldt
    If Me.f_medarbnr.Value <> "" And _
        Me.f_navn.Value <> "" And _
            Me.f_adresse.Value <> "" And _
                Me.f_postnr.Value <> "" And _
                    Me.f_timesats.Value <> "" And _
                        Me.f_by.Value <> "" Then
                If Me.f_gem.BackColor = grøn Then
                    OpdaterIArk rækIArk
                Else
                    OpdaterIArk aktuelleRæk
                End If
    Else
        MsgBox ("Alle felter skal udfyldes")
        Me.f_medarbnr.SetFocus
    End If
End Sub
Private Sub f_visAktuelleRække_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If IsNumeric(Me.f_visAktuelleRække.Value) = True And _
        Val(Me.f_visAktuelleRække.Value) > 1 And _
            Val(Me.f_visAktuelleRække.Value) <= rækIArk Then
                aktuelleRæk = Val(Me.f_visAktuelleRække)
                visAktuelleRække
    End If
End Sub

Private Sub SpinButton1_SpinUp()
    If aktuelleRæk - 1 >= 11 Then
        aktuelleRæk = aktuelleRæk - 1
    End If
    visAktuelleRække
End Sub
Private Sub SpinButton1_SpinDown()
    If aktuelleRæk + 1 <= rækIArk Then
        aktuelleRæk = aktuelleRæk + 1
    End If
    visAktuelleRække
End Sub
Private Sub visAktuelleRække()
    Me.f_visAktuelleRække.Value = aktuelleRæk
        If aktuelleRæk = rækIArk Then
            Me.f_visAktuelleRække.BackColor = grøn
            Me.f_gem.Caption = "Gem"
            Me.f_gem.Accelerator = "G"
            Me.f_gem.BackColor = grøn
        Else
            Me.f_visAktuelleRække.BackColor = gul
            Me.f_gem.Caption = "Ret/slet"
            Me.f_gem.Accelerator = "K"
            Me.f_gem.BackColor = gul
            Me.f_sletRækkedata = False
        End If
   
    If Cells(aktuelleRæk, 1) <> "" Then
        Me.f_medarbnr.Value = Cells(aktuelleRæk, 1)
        Me.f_navn.Value = Cells(aktuelleRæk, 2)
        Me.f_adresse.Value = Cells(aktuelleRæk, 3)
        Me.f_postnr.Value = Cells(aktuelleRæk, 4)
        Me.f_by.Value = Cells(aktuelleRæk, 5)
        Me.f_tlf.Value = Cells(aktuelleRæk, 6)
        Me.f_fax.Value = Cells(aktuelleRæk, 7)
        Me.f_timesats.Value = Cells(aktuelleRæk, 8)
       
       
       
       
       
        Me.f_sletRækkedata.Enabled = True
    Else
        ClearFelter
        Me.f_sletRækkedata.Enabled = False
    End If
   
    Cells(aktuelleRæk, 1).Select
End Sub
Private Sub UserForm_activate()
    ActiveWorkbook.Sheets(2).Select
   
    rækIArk = findFørsteLedigeRække
    aktuelleRæk = rækIArk
    visAktuelleRække
    Cells(rækIArk, 1).Select
   
    ClearFelter
    Me.f_medarbnr.SetFocus
End Sub
Private Sub ClearFelter()
    Me.f_medarbnr.Value = ""
    Me.f_navn.Value = ""
    Me.f_adresse.Value = ""
    Me.f_postnr.Value = ""
    Me.f_by.Value = ""
    Me.f_tlf.Value = ""
    Me.f_fax.Value = ""
    Me.f_timesats.Value = ""
   
   
   
    Me.f_medarbnr.SetFocus
End Sub
Private Sub OpdaterIArk(række)
    If Me.f_sletRækkedata = False Then
        Cells(række, 1) = Me.f_medarbnr.Value
        Cells(række, 2) = Me.f_navn.Value
        Cells(række, 3) = Me.f_adresse.Value
        Cells(række, 4) = Me.f_postnr.Value
        Cells(række, 5) = Me.f_by.Value
        Cells(række, 6) = Me.f_tlf.Value
        Cells(række, 7) = Me.f_fax.Value
        Cells(række, 8) = Me.f_timesats.Value
    Else
        Rows(CStr(række) + ":" + CStr(række)).Select
        Selection.Delete Shift:=xlUp
    End If
       
    rækIArk = findFørsteLedigeRække
    aktuelleRæk = rækIArk
    visAktuelleRække
    Cells(rækIArk, 1).Select
    ClearFelter
End Sub
Private Function findFørsteLedigeRække()
Dim r
    For r = 11 To 65000
        If Cells(r, 1) = "" Then
            findFørsteLedigeRække = r
            Exit Function
        End If
    Next r
End Function

1. Kan man lave et lopslag som slår værdien til venstre for søgeværdien op ?

hvis det er et tal, så
=SUMPRODUKT((B1:B100 =C2)*(A1:A100))

"2. Prøv at se denne løsning (fra Supertekst faktisk). Man kan taste linienummer i funktionen "visaktuellerække" og så viser den værdierne i userformen for den linie i regnearket. Men kan man ændre det så den slå værdierne i kolonne A op og viser dem i userformen:"

Hvor står det den skal søge efter ??
Hvilket Ark og hvilken kolonne ??

Det første spørgsmål fandt jeg også selv lige ud af på denne måde:

=INDEKS( Varenr; SAMMENLIGN( B19; Materialer; 0))

Spørgsmål 2: Altså hvis jer udfylder userformen og trykker gem så står der fra kolonne A til G: medarbnr, navn, projekt, ugedag, uge, timer

Hvis jeg så står i userformen igen så kan jeg bruge spinbutton til at bladre om og ned i de rækker med data i og hvis der står data på rækken så viser den automatisk de data i userformen så jeg kan rette dem.
Jeg kan også bare skrive rækkenummeret i søgefeltet i userformen, så viser den dataene fra den pågældende række.

Men i stedet for at skrive rækkenr. vil jeg hellere skrive medarbnr., altså værdien fra kolonne A. Og hvis det medarbejdernummer findes skal den returner hele rækkens data til userformen.

Ovenstående er et eksempel og hænger ikke helt sammen med den makro jeg har vist kan jeg se (der er lidt andre værdier i den)

Men princippet er det samme. Det er kolonne A, den skal søge i i stedet for rækkenummeret.

Vedr. skrivebeskyttet Data.xls

Det virker som om at efter jeg har "brugt" data-filen, altså hentet data fra den fra en skabelon e.l., så er den efter Excel's termer stadig åben/og dermed skrivebeskyttet i ca. 5-10 minutter.

Man kan dog ikke se at filen er åben.

Efter 5-10 minutter så er den mulig at åbne igen ???

Er det fordi nogle af makroerne skal søge en hulens bunke linier igennem ???

Det er ikke optimalt at man ikke kan bruge data-filen andet end med 5-10 minutters mellemrum.

Hejsa kabbak og Supertekst

Er der nogen som har haft tid til at kigge på mine evige problemer ?

Bare lige en venlig forespørgsel...

Lukker spørgsmålet

Kom med nogle svar både kabbak og supertekst så delere jeg pointene imellem jer.

Spørgsmål vedr. visaktuellerække oprettes i et nyt spørgsmål

OK - har ikke tid p.t. - men tak.....

Helt i orden

Derfor flytter jeg også spørgsmålet så andre måske kan hjælpe.

Tak for hjælpen indtil videre i hvert fald.

et svar ;-))