Problemen met automatische afsluiten werkbook

[Nico S]

Graag zou ik wat hulp willen met het volgende probleem. Ik ben voor het eerst aan het spelen met VB en heb inmiddels een code waarmee ik uit een ander bestand gezochte waarden kan copy/paste-en. Alles werkt als een zonnetje, maar het afsluiten van alleen het bestand met de gezochte getallen wil maar niet lukken. Waar loopt de code spaak?

Sub ImportGrenzen()
' Deze macro heeft tot doel het importeren van de nieuwste getallen.

    'openen van de file met gezochte waarden.
    fileToOpen = Application _
        .GetOpenFilename("Excel files (*.xls), *.xls")
        
    Application.ScreenUpdating = False
    
    If fileToOpen <> False Then
        Workbooks.Open fileToOpen
        
        For Each ws In Worksheets
            If ws.Name = "deze pagina" Then
                Range(A1:B1).Activate
                Selection.Copy

                ThisWorkbook.Activate 'Terug naar bestand waar getallen naar toe moeten
                Range("I8:J8").Activate
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                 :=False, Transpose:=False
                
                Exit For
            End If
        Next
        
        'Om af te sluiten?
        
        'ActiveWindow.Close    ' Werkt niet!
        
        'Workbooks.Close fileToOpen 'Werkt niet!
        
        'fileToOpen.Close      ' Werkt niet!
        
        'Workbooks("fileToOpen").Activate
        'With ActiveWorkbook
        '    .RunAutoMacros xlAutoClose
        '    .Close
        'End With              ' Werkt niet!

    End If
    
    Application.ScreenUpdating = True
    
End Sub

Bij voorbaat dank voor jullie hulp. Een bonusje voor degene die ook bij het doorzoeken van de laatste pagina, zonder vinden van "deze pagina", een MsgBox kan toevoegen. De eeuwige roem! :thumb:

 

[Wigi]

Je maakt het jezelf nodeloos complex.

Sub ImportGrenzen()
' Deze macro heeft tot doel het importeren van de nieuwste getallen.

    'openen van de file met gezochte waarden.
    fileToOpen = Application.GetOpenFilename("Excel files (*.xls), *.xls")
    
    Application.ScreenUpdating = False
    
    If fileToOpen <> False Then
    
        Workbooks.Open fileToOpen
        
        Worksheets("deze pagina").Range("A1:B1").Copy
        ThisWorkbook.Sheets("NAAMVANDESHEET").Range("I8:J8").PasteSpecial xlValues
        
        ActiveWorkbook.Close False
        
    End If
    
    Application.ScreenUpdating = True
    
End Sub

Vervang NAAMVANDESHEET nog.

ongeteste code

Wigi

 

[Nico S]

Moeilijk met een reden

Beste Wigi,

Dank je wel voor je snelle reactie. Je hebt de code idd erg vereenvoudigd. Ik heb juist bewust geprobeerd om de code algemeen toepasbaar te maken, wat het allemaal wat moeilijker maakt. Verder probeerde ik de code fool-proof te maken met de extra controle op het tabblad "deze pagina". Verder had ik de code iets vereenvoudigd, omdat ik dacht dat het niet zou uitmaken, maar dat doet het dus wel (een echte beginneling).

Binnen de For Each blok zou moeten staan:

 If ws.Name = "deze pagina" Then
                Set fc = Worksheets("deze pagina").Columns("C").Find("", LookIn:=xlValues)
                Range(fc.Address).Activate
                ActiveCell.Offset(-1, 0).Range("A1:B1").Select
                Selection.Copy
        
                ' Activeer de uitgangsfile weer en plak gegevens op een lege regel
                ThisWorkbook.Activate
                Set ft = Range("T10:T70").Find("", LookIn:=xlValues)
                Range(ft.Address).Activate
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                 :=False, Transpose:=False
                
                Exit For
 End If

Het gaat hier dus om een bepaalde pagina uit een wisselend bestand waar de laatste getallen uit gehaald moeten worden (met controle op de aanwezigheid van het tabblad, eventueel met foutmelding bij afwezigheid).

Deze getallen moeten geplakt worden in het bestand en de pagina waarvanuit deze code is gestart, op de eerste lege regel. Is het zoeken van deze regel ook mogelijk zonder het gebruik van Activate?

 

[Nico S]

Schuiven helpt

Beste Wigi,

Je hebt me toch er goed op weg geholpen. Met een simpelere code kwam ik niet, maar door het zoeken naar de juiste doel lokatie te verplaatsten werkt de code weer als een zonnetje. Thanks. Voor iedereen met vergelijkbare problemen, dit was mijn oplossing.

Sub ImportGrenzen()
     
    fileToOpen = Application.GetOpenFilename("Excel files (*.xls), *.xls")

    Application.ScreenUpdating = False 'onderstaande handelingen zijn niet zichtbaar
    
    ThisWorkbook.Activate           'De laatste lege regel in het uitgangsbestand/doel bestand wordt geselecteerd
    Set ft = Range("T10: T70 ").Find("", LookIn:=xlValues)
    
    
    'openen van WORKBOOK en juiste WORKSHEET.
    
    If fileToOpen <> False Then     'Als er een bestand is geselecteerd, dan wordt deze nu geopend.
        Workbooks.Open fileToOpen
        
        'Deze functie copieerd de twee laatste waarden uit kolom C van WORKBOOK,
        '"WORKSHEET" naar uitgangsbestand
        For Each ws In Worksheets
            If ws.Name = "WORKSHEET" Then
                Set fc = Worksheets("WORKSHEET").Columns("C").Find("", LookIn:=xlValues)
                Range(fc.Address).Activate
                ActiveCell.Offset(-1, 0).Range("A1:B1").Select
                Selection.Copy
        
                ' Activeer de uitgangsfile weer en plak gegevens op een lege regel
                
                ThisWorkbook.Sheets("DOEL").Range(ft.Address).PasteSpecial xlValues
                                                
                'Sluiten van de WORKBOOK
                ActiveWorkbook.Close False
                
                Exit For
            End If
        Next
       
    End If
    
    Application.ScreenUpdating = True 'Beeldscherm mag weer gewoon ververst worden.

    
End Sub

Succes

 

[snb]

Dat kan 'iets' korter:

Sub ImportGrenzen()
  On Error Resume Next
  With Workbooks.Add(Application.GetOpenFilename("Excel files (*.xls), *.xls"))
    If Err.Number = 0 Then .Sheets(1).Cells(Rows.Count, 3).End(xlUp).Offset(-1).Resize(2).Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 20).End(xlUp).Offset(1)
  End With
End Sub

 

[Nico S]

Moooiiiiii

Masterlijk snb

Dat kan 'iets' korter:

Sub ImportGrenzen()
  On Error Resume Next
  With Workbooks.Add(Application.GetOpenFilename("Excel files (*.xls), *.xls"))
    If Err.Number = 0 Then .Sheets(1).Cells(Rows.Count, 3).End(xlUp).Offset(-1).Resize(2).Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 20).End(xlUp).Offset(1)
  End With
End Sub

Alleen werkt het niet. Ik krijg de error dat de geselecteerde cellen buiten het bereik vallen. Zover ik zie wordt er niets gekopieerd noch geplakt. Misschien dat ik er nog even mee ga spelen om te kijken waar het mis gaat. Thanks.

 

[Wigi]

Zet

On Error Resume Next

in commentaar om beter te debuggen.