cel gegevens kopieren naar nieuw gemaakt bestand.

[buckeru]

Hoi,
Ik open via een macro een bepaald bestand, en moet de gegevens van cel f7 van het huidige bestand copieren naar f7 in het nieuwe bestand.
Maar het lukt me maar niet. Dank zij edmoor ben ik al een eind opweg, maar het laatste stukje moet nog.
wie o wie.

 bestand = "C:\Documents\" & Range("Blad2!G2").Value & ".xls"

    If Dir(bestand) = "" Then
        MsgBox ("Bestand niet gevonden: Probeer opnieuw")
        Range("F7").Select
        Selection.ClearContents
        Range("D7").Select
        Selection.ClearContents
        Exit Sub
    End If
    
    Workbooks.Open Filename:=bestand
    
    ThisWorkbook.Activate
        Range("F7").Select          'cel F7 moet gecopieerd worden naar het nieuwe bestand
        Selection.Copy
        [COLOR="red"]Workbooks.Select[/COLOR]             'Hier moet de code komen voor het nieuwe bestand
        Range("F7").Select          'Op F7 in het nieuwe bestand moet geplakt worden.
        Application.CutCopyMode = False
        
        'hieronder wordt dit bestand gecleard en gesaved
            Range("F7").Select
            Selection.ClearContents
            Range("D7").Select
            Selection.ClearContents
    ThisWorkbook.Close SaveChanges:=True
         
    
End Sub

in het rode loopt het vast? naam van het bestand veranderd steeds, en
weet de code niet?

the rookie

 

[wampier]

Je kunt dit soort scripts beter herschrijven nadat ze zijn opgenomen.

Ik begrijp alleen het onderste deel van het script niet? je probeert eerst F7 in het nieuwe bestand te plakken en vervolgens F7 weer te wissen (in het nieuwe bestand)? Het is beter om een link te maken naar beide bestanden en die link te gebruiken. dat scheelt een hoop verwarring.

 bestand = "C:\Documents\" & Range("Blad2!G2").Value & ".xls"

    If Dir(bestand) = "" Then
        MsgBox ("Bestand niet gevonden: Probeer opnieuw")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If
    
    Set oudB = ActiveWorkbook
    Set nieuwB = Workbooks.Open (bestand)

    nieuwB.ActiveSheet.Range("f7") = oudB.ActiveSheet.Range("f7")
    nieuwB.Close SaveChanges:=True

Ik heb even het wissen weggelaten omdat het onduidelijk is of het wissen moet plaatsvinden in het nieuwe of oude bestand.

 

[buckeru]

ok, het werkt
maar in het oude werkbook moeten de cellen
f7 en d7 nog gewist worden.
ik heb al wat geprobeerd , maar helaas.

bestand = "C:\Documents\" & Range("Blad2!G2").Value & ".xls"
    
    If Dir(bestand) = "" Then
        MsgBox ("Bestand niet gevonden: Probeer opnieuw")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If
    
    Set oudB = ActiveWorkbook
    Set nieuwB = Workbooks.Open(bestand)

    nieuwB.ActiveSheet.Range("f7") = oudB.ActiveSheet.Range("f7")
    [COLOR="red"]'oudB.ActiveSheet.select
    'Union([f7], [d7]).ClearContents[/COLOR]
    oudB.Close SaveChanges:=True

kan je mij hier nog door heen lijden

 

[wampier]

Leiden wel, lijden hoop ik niet

Het makkelijkste is om eerst de nieuwe file te sluiten, je komt dan automatisch weer terecht op het oude sheet en kun je de union gebruiken.

als je oudB will gebruiken kan het zo:

 With oudb.ActiveSheet
    .Range("f7").ClearContents
    .Range("d7").ClearContents
 End With

Een union is ook wel mogelijk, maar is in dit geval net zoveel typewerk Probeer af te leren select te gebruiken. In principe is het nooit nodig en veroorzaakt vaak onverwachte resultaten

 

[buckeru]

Super bedankt.
heb nog 1 vraag. controle of het nieuwe bestand al in gebruik is.
Zo ja mag het niet opnieuw geopend worden.
melding, invoer wissen en exit sub.
Ben al bezig geweest maar lukt nog niet.
Heb 3 opties gevonden.

bestand = "C:\Documents\" & Range("Blad2!G2").Value & ".xls"
    
    If Dir(bestand) = "" Then

        MsgBox ("Bestand niet gevonden: Probeer opnieuw")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If
    
    'controle of bestand al open is
    
       [COLOR="red"]'If Dir(bestand) = Active Then
       'If WorkbookIsOpen(bestand) Then
       'If IsFileOpen("C:\bestand") Then[/COLOR]         
       'MsgBox ("Bestand is in gebruik")
         'Union([f7], [d7]).ClearContents
         'Exit Sub
    'End If
        
    
    
    Set oudb = ActiveWorkbook
    Set nieuwB = Workbooks.Open(bestand)

    nieuwB.ActiveSheet.Range("f7") = oudb.ActiveSheet.Range("f7")
    
    With oudb.ActiveSheet
        .Range("f7").ClearContents
        .Range("d7").ClearContents
    End With
    
    oudb.Close SaveChanges:=True

      
   
End Sub

 

[wampier]

Dat is wel mogelijk, je moet dan Blad2!g2 zoeken in workbooks. Echter met de huidige macro zou dat nooit voor moeten kunnen komen, tenzij BLAD2!G2 is gevult met zijn eigen naam, maar dat kun je makkelijk controleren natuurlijk.

 

[buckeru]

Het is wel mogelijk, maar ik weet niet precies hoe ik het moet uitleggen.
Het bestand roept een andere xls file bv BR R 3101 a , die ik gebruik, maar die is niet altijd in gebruik.
als deze wel in gebruik is en men wil deze oproepen via dit bestand met de macro. dan moet men wachten tot het bestand helemaal klaar is.
dus wat ik eigenlijk wil, is of de macro kijkt of dat bestand in gebruik/open is. En hoeft alleen maar een melding te geven "in gebruik" en de controle kan dan stoppen.
in de code had ik al wat gezet in rood, maar daar lukt het nog niet mee.
hoop dat het duidelijk is.

 

[wampier]

Let wel, indien het bestand benaderd wordt vanuit andere computers / netwerk is het niet eenvoudig om na te gaan (in VBA) of het bestand in gebruik is. Indien het bestand is "ge-locked" krijg je vanzelf de melding dat het bestand al in gebruik is door iemand.

Dus, is dat voor gebruik op dezelfde computer door een enkel persoon? of wordt de target file benaderd via netwerken e.d.?

 

[buckeru]

Het bestand is in principe door iedereen op het werk benaderbaar.
maar wordt eigenlijk alleen door 1 pers gebruikt.
het staat op het werk ergens op een g schijf.

 

[wampier]

Als de file niet gelocked wordt door je domain is er geen manier om er achter te komen of dat iemand de file al open heeft. Indien de file wel gelocked wordt, kan de tweede persoon automatisch niet saven totdat de eerste persoon klaar is.

Dat is precies waarom er databases zijn uitgevonden

 

[buckeru]

ok, het wil dus niet zo eenvoudig als ik dacht.
en die codes van mij

'If Dir(bestand) = Active Then
       'If WorkbookIsOpen(bestand) Then
       'If IsFileOpen("C:\bestand") Then

daar wil het dus niet mee.

mmmmmmm
jammer.

 

[Warme bakkertje]

Probeer het eens met onderstaande. Zet alles in een standaardmodule en wijzig bij TestVBA de Const in het volledige pad naar het bewuste bestand. Draai dan TestVBA eens.

Sub TestVBA()
'// Just change the file to test here
Const strFileToOpen As String = "E:\Testbestanden\Bestand_In_Gebruik.xls"
    
    If IsFileOpen(strFileToOpen) Then
        MsgBox strFileToOpen & " is already Opened" & _
            vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"
    Else
        MsgBox strFileToOpen & " is not open", vbInformation
    End If
End Sub

Function IsFileOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
'// We can use this for ANY FILE not just Excel!
'// Ivan F Moala
'// [url]http://www.xcelfiles.com[/url]
Dim hdlFile As Long

    '// Error is generated if you try
    '// opening a File for ReadWrite lock >> MUST BE OPEN!
    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:
    '// Someone has it open!
    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

 

[buckeru]

zo das niet mis, hier mijn poging en resultaten.

ik heb het pad veranderd naar c:\documents\BR R 3101 n. maar dat laatste veranderd. zie sub BR_zoeken. Daar kan dus niet een vast adres staan.
als ik het nu uitvoer krijg ik de melding c:\documents\BR R 3101 n is not open, dat klopt, en verder gebeurd er niets.
Als het bestand wel geopend is, komt de melding c:\documents\BR R 3101 n is aleady open by f. en doet verder niets, en dat is goed.

Sub TestVBA()
'// Just change the file to test here
Const strFileToOpen As String = "C:\Documents\BR R 3101 n.xls"
    
    If IsFileOpen(strFileToOpen) Then
        MsgBox strFileToOpen & " is already Opened" & _
            vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"
    Else
        MsgBox strFileToOpen & " is not open", vbInformation
    End If
End Sub

Function IsFileOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
'// We can use this for ANY FILE not just Excel!
'// Ivan F Moala
'// http://www.xcelfiles.com
Dim hdlFile As Long

    '// Error is generated if you try
    '// opening a File for ReadWrite lock >> MUST BE OPEN!
    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:
    '// Someone has it open!
    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

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
     
    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

         
End Sub

er zit dus nog ergens wat niet goed?

 

[wampier]

Kijk, daar zat ik dus mee:

Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile

Als het open statement wordt uitgevoerd zonder die toevoeging werkt het namelijk wel en krijg je geen error. Wist eigenlijk niet dat het als parameter meegegeven kon worden bij OPEN. Live and learn.

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(bestand) Then
        MsgBox ("Bestand in gebruik")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If

 

[buckeru]

?, wat moet ik nu doen. deze code plakken in BR_zoeken. samen met die code van warme bakker?
dan veranders er niets.
en als ik hem plak in hetgeen wat ik al had, dus zonder warme bakker, dan komt er een fout
sub of function is niet gedefinieerd-->bij If IsFileOpen(bestand) Then

 

[wampier]

IsFileOpen is een eigen gedefineerde functie die je moet toevoegen aan je project inderdaad. Het hele stuk wat je in je post geplakt had met de 4 regels aanpassing die ik had geschreven en je macro zou nu moeten stoppen als de file open is.

 

[buckeru]

ok, hoe of waar voeg je dit toe aan het project?

 

[wampier]

gewoon de text onder (of boven) je huidige routines plakken. Dus:

Function IsFileOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
'// We can use this for ANY FILE not just Excel!
'// Ivan F Moala
'// http://www.xcelfiles.com
Dim hdlFile As Long

    '// Error is generated if you try
    '// opening a File for ReadWrite lock >> MUST BE OPEN!
    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:
    '// Someone has it open!
    IsFileOpen = True
    Close hdlFile
End Function

onder de "end sub" van je routine plaatsen en de error dat de functie IsFileOpen niet bestaat gaat weg

 

[buckeru]

ik heb nu alles erin geplakt, maar werkt nog niet.

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(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



Sub TestVBA()
'// Just change the file to test here
Const strFileToOpen As String = "C:\Documents\[COLOR="red"]BR R 3101 n[/COLOR].xls"
    
    If IsFileOpen(strFileToOpen) Then
        MsgBox strFileToOpen & " is already Opened" & _
            vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"
    Else
        MsgBox strFileToOpen & " is not open", vbInformation
    End If
End Sub

Function IsFileOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
'// We can use this for ANY FILE not just Excel!
'// Ivan F Moala
'// http://www.xcelfiles.com
Dim hdlFile As Long

    '// Error is generated if you try
    '// opening a File for ReadWrite lock >> MUST BE OPEN!
    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:
    '// Someone has it open!
    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

wat ik nu rood heb staan, moet daar (bestand) komen te staan?
dat is toch die variabele?

 

[wampier]

De routine "testVBA" heb je niet nodig. Die demonstreert alleen maar de werking van "IsFileOpen"

mijn code:

    If IsFileOpen(bestand) Then
        MsgBox ("Bestand in gebruik")
        Union([f7], [d7]).ClearContents
        Exit Sub
    End If

Controleert of "bestand" al open is. Wil je controleren op een andere file kun je de code eenvoudig aanpassen met een nieuwe variabele.

Bijvoorbeeld:

bestand2 = "C:\Documents\" & Range("Blad2!G3").Value & ".xls"

en dan in plaats van bestand in mijn code bestand2 gebruiken.