cel gegevens kopieren naar nieuw gemaakt bestand.

[buckeru]

ik krijg het helaas niet goed.
compileerfout: ByRef- Argumenttypen komen niet overeen.
bestand licht op

Sub BR_zoeken()


'bestand zoeken in c:\Documents\
' met de waarde uit dit bestand van blad2 cel G2
'  en daarna dat bestand te openen


    bestand = "C:\Documents\" & Range("Blad2!G2").Value & ".xls"
    
    If Dir(bestand) = "" & Active Then
        MsgBox ("Bestand niet gevonden: Probeer opnieuw")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If
    
    If IsFileOpen([COLOR="red"]bestand[/COLOR]) Then
        MsgBox ("Bestand in gebruik")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If
     
    Set oudb = ActiveWorkbook
    Set nieuwB = Workbooks.Open(bestand)
    
    ActiveSheet.Unprotect Password:="pop"

    nieuwB.ActiveSheet.Range("f7") = oudb.ActiveSheet.Range("f7")
    Range("T4").Select
    
    ActiveSheet.Protect Password:="pop"
    
    
    With oudb.ActiveSheet
        .Range("f7").ClearContents
        .Range("d7").ClearContents
    End With
    
    oudb.Close SaveChanges:=True

    
    Function IsFileOpen(strFullPathFileName As String) As Boolean
        Dim hdlFile As Long
        On Error GoTo FileIsOpen:
        hdlFile = FreeFile
        Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
        IsFileOpen = False
        Close hdlFile
    Exit Function

    
FileIsOpen:
    IsFileOpen = True
    Close hdlFile
    
    Function LastUser(path As String)

    Dim text As String
    Dim strFlag1 As String, strflag2 As String
    Dim i As Integer, j As Integer

    strFlag1 = Chr(0) & Chr(0)
    strflag2 = Chr(32) & Chr(32)

    Open path For Binary As #1
    text = Space(LOF(1))
    Get 1, , text
    Close #1
    j = InStr(1, text, strflag2)
    i = InStrRev(text, strFlag1, j) + Len(strFlag1)
    LastUser = Mid(text, i, j - i)

End Function

heb al heel wat geprobeerd

 

[wampier]

zet eens net boven "bestand ="

het volgende:

dim bestand as string

mogelijke andere fout: waar is de "EXIT SUB" na oudb.Close ?? die moet er wel staan.

Maar normaal gezien moet dat als string gewoon werken.

 

[buckeru]

ik heb gedaan zoals jij zij
als ik dan de macro uitvoer komt er compileerfout: er wordt een end sub verwacht.
deze toegevoegd na de net toegevoegde exit sub.
nu split het scherm: er komt een lijn in. boven de lijn zit ik in BR_zoeken
en onder de lijn zit ik in InFileOpen.
als ik nu de macro uitvoer compileerfout: er wordt End Function verwacht.
deze toegevoegd na: Close hdlFile. er komt nu weer zo'n lijn in, en zit ik in LastUser.
macro uitgevoerd en...........het werkt.
ga nog een half uurtje testen.
hierbij de voledige code voor de liefhebber.

Sub BR_zoeken()


'bestand zoeken in c:\Documents\
' met de waarde uit dit bestand van blad2 cel G2
'  en daarna dat bestand te openen

    Dim bestand As String
    
    bestand = "C:\Documents\" & Range("Blad2!G2").Value & ".xls"
    
    If Dir(bestand) = "" & Active Then
        MsgBox ("Bestand niet gevonden: Probeer opnieuw")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If
    
    If IsFileOpen(bestand) Then
        MsgBox ("Bestand in gebruik")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If
     
    Set oudb = ActiveWorkbook
    Set nieuwB = Workbooks.Open(bestand)
    
    ActiveSheet.Unprotect Password:="pop"

    nieuwB.ActiveSheet.Range("f7") = oudb.ActiveSheet.Range("f7")
    Range("T4").Select
    
    ActiveSheet.Protect Password:="pop"
    
    
    With oudb.ActiveSheet
        .Range("f7").ClearContents
        .Range("d7").ClearContents
    End With
    
        oudb.Close SaveChanges:=True
    Exit Sub
    
    End Sub
    
    
    Function IsFileOpen(strFullPathFileName As String) As Boolean
        Dim hdlFile As Long
        On Error GoTo FileIsOpen:
        hdlFile = FreeFile
        Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
        IsFileOpen = False
        Close hdlFile
    Exit Function
    
FileIsOpen:
    IsFileOpen = True
    Close hdlFile
    End Function
    Function LastUser(path As String)

    Dim text As String
    Dim strFlag1 As String, strflag2 As String
    Dim i As Integer, j As Integer

    strFlag1 = Chr(0) & Chr(0)
    strflag2 = Chr(32) & Chr(32)

    Open path For Binary As #1
    text = Space(LOF(1))
    Get 1, , text
    Close #1
    j = InStr(1, text, strflag2)
    i = InStrRev(text, strFlag1, j) + Len(strFlag1)
    LastUser = Mid(text, i, j - i)

End Function

super bedankt voor de ondersteuning:thumb:
zonder jou en anderen was het niet gelukt.

thnx

 

[wampier]

de exit sub na de close kan weg. "end sub" alleen is voldoende. Mijn fout, had even verder na moeten denken, maar dat krijg je soms als je meerdere vragen tegelijk bekijkt op helpmij