Closing excel instance seems impossible....

[Thingol]

Hi All,

I've made a script that I use to convert a set of tab separated text files into formatted excelsheets. The script works, except that it leaves an instance of excel open, even though I think I am closing it and removing it from memory. I read about 10 threads on different fora before I posted the code below. I think I've done all I should. I close the workbooks, worksheets and quit the app and destroy all object variables. I use late binding and I believe I don't have any unqualified references in there.

Can anyone spot my error? Cause I don't see it.

Thanks a lot for any help!

Bets regards,
Martijn Senden.
p.s. The comments and many of the variables are in Dutch, I hope that's not a problem.

Public Sub conversie_tekst_excel()
'=================================================================================
'1.) Deze routine converteert de gegevens uit de DINO-tekstbestanden
'    naar excelbestanden met Rockware-veldindeling
'=================================================================================

'Excelobjecten declareren en instellen
Dim objXLapp As Object
Dim objXLWorkbook As Workbook
Dim objXLWorksheet1 As Worksheet
Dim objXLWorksheet2 As Worksheet
Dim objXLWorksheet3 As Worksheet
Set objXLapp = CreateObject("Excel.Application")
    
'Variabelen voor conversieroutine declareren
Dim Titel As String
Dim Filter As String, Title As String, msg As String
Dim i As Integer, FilterIndex As Integer
Dim Bestandsnaam As Variant
Dim Pad As String
Dim Station As String
Dim Bericht As String
Dim strComment As String
Dim Bladnaam As String
Dim c As Variant
Dim dblVoortgangMax As Double
Dim intAantalBestanden As Integer

'Excel starten en conversie van tekstbestanden uitvoeren
With objXLapp
    ' Bestandsfilters
    Filter = "Text Files (*.txt),*.txt,"
    ' Standaardfilter instellen op *.txt
    FilterIndex = 1
    
    ' Stel de titel van het dialoogvenster in
    Titel = "Kies de bestand(en) die u wilt openen"
    
    ' Kies de drive en het pad waarin gewerkt moet worden
    Pad = Left$(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
    Station = Left(Pad, 1)
    ChDrive (Station)
    ChDir (Pad)
    
    ' Stel het Array van bestandsnamen in op de geselecteerde bestanden (toestaan meerdere bestanden)
    Bestandsnaam = .GetOpenFilename(Filter, FilterIndex, Titel, , True)
    ' Reset het beginstation/-pad
    ChDrive (Left(.DefaultFilePath, 1))
    ChDir (.DefaultFilePath)
    
    ' Stoppen als er geannuleerd wordt
    If Not IsArray(Bestandsnaam) Then
        MsgBox "Er was geen bestand geselecteerd." & Chr(10) & "Er is niets geïmporteerd."
        Exit Sub
    End If

    DoCmd.Hourglass True 'Zandloper aanzetten
    
    intAantalBestanden = UBound(Bestandsnaam)
    
    'Voortgangsformulier openen en voortgang op nul zetten
    DoCmd.OpenForm ("frmVoortgangConversieDINO_Rockware")
    dblVoortgangMax = Forms!frmVoortgangConversieDINO_Rockware.txtVoortgang.Width
    Forms!frmVoortgangConversieDINO_Rockware.txtVoortgang.Width = 0
    Forms!frmVoortgangConversieDINO_Rockware.lblVoortgang.Caption = "(0 van " & UBound(Bestandsnaam) & " bestanden geconverteerd)"
    Forms!frmVoortgangConversieDINO_Rockware.lblPercentage.Caption = "0%"
    Forms!frmVoortgangConversieDINO_Rockware.Repaint
    
    ' Bestanden openen
    For i = LBound(Bestandsnaam) To UBound(Bestandsnaam)
        .Workbooks.OpenText FileName:=Bestandsnaam(i), DataType:=1, Tab:=True
        Set objXLWorkbook = .ActiveSheet.Parent
        Set objXLWorksheet1 = .ActiveSheet
        
        'Kopgegevens selecteren die getransponeerd moeten worden
        .Range("A2:B16").Select
        .Selection.Copy
        
        'Getransponeerde gegevens plakken
        .Range("C2").Select
        .Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
       
        'Oude cellen verwijderen
        .Range("A2:B16").Select
        .Selection.Delete Shift:=xlToLeft
        
        'Boringnummer kopiëren naar lithologische records
        .Range("A3").Select
        .Selection.Copy
        .Cells.Find(What:="Bovenkant laag (m beneden maaiveld)", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Select
        .Range(.Selection, .Selection.End(xlDown)).Select
        .Selection.Insert Shift:=xlToRight
        .Cells.Find(What:="Bovenkant laag (m beneden maaiveld)", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Select
        .Selection.Offset(0, -1).Value = "Name"
        
        'Lithologische gegevens naar nieuw tabblad kopiëren
        Bladnaam = objXLWorksheet1.Name
        Set objXLWorksheet2 = .Sheets.Add
        objXLWorksheet2.Name = "Lithologie"
        objXLWorksheet1.Select
        .Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Select
        .Range(.Selection, .Selection.End(xlDown)).Select
        .Range(.Selection, .Selection.End(xlToRight)).Select
        .Selection.Copy
        objXLWorksheet2.Select
        .Range("a1").Select
        objXLWorksheet2.Paste
        
        'Kopgegevens naar nieuw tabblad kopiëren
        Set objXLWorksheet3 = .Sheets.Add
        objXLWorksheet3.Name = "Kopgegevens"
        objXLWorksheet1.Select
        .Range("A2:O3").Select
        .Selection.Copy
        objXLWorksheet3.Select
        .Range("a1").Select
        objXLWorksheet3.Paste
        
        'Volgorde sheets aanpassen
        objXLWorksheet2.Move After:=objXLWorksheet3
        
        'Oorspronkelijke worksheet verwijderen
        .DisplayAlerts = False
        objXLWorksheet1.Delete
        .DisplayAlerts = True
        Set objXLWorksheet1 = Nothing
        
        'Veldnamen in lithologie tabblad wijzigen
        objXLWorksheet2.Select
        .Range("B1").Value = "Depth1"
        .Range("C1").Value = "Depth2"
        .Range("D1").Value = "LithTypeId"
        .Range("E1").Value = "Comment"
        
        'Veld LithTypeId wijzigen
        .Range("D2").Select
        If .Range("D3").Value <> "" Then
            .Range(.Selection, .Selection.End(xlDown)).Select
        End If
        For Each c In .Selection.Cells
            Select Case c.Offset(0, 1).Value
                Case "klei": c.Value = 1
                Case "veen": c.Value = 4
                Case "leem": c.Value = 10
                Case "stenen": c.Value = 12
                Case "grind": c.Value = 13
                Case "schelpen": c.Value = 14
                Case "gyttja": c.Value = 59
                Case "zand"
                    Select Case c.Offset(0, 4).Value
                        Case "matig fijn": c.Value = 2
                        Case "matig grof": c.Value = 6
                        Case "grove categorie": c.Value = 7
                        Case "fijne categorie": c.Value = 9
                        Case "zeer fijn": c.Value = 11
                        Case "zeer grof": c.Value = 16
                        Case "uiterst grof": c.Value = 17
                        Case "uiterst fijn": c.Value = 22
                        Case Else
                            c.Value = 15
                    End Select
                Case Else
                    c.Value = 61
            End Select
        Next c
            
        'Veld Comment vullen
        .Range("E2").Select
        If .Range("E3").Value <> "" Then
            .Range(.Selection, .Selection.End(xlDown)).Select
        End If
        For Each c In .Selection.Cells
            Select Case c.Offset(0, 4).Value
                Case "---": strComment = ""
                Case Else
                    strComment = c.Offset(0, 4).Value
            End Select
            Select Case c.Offset(0, 6).Value
                Case "---": strComment = strComment
                Case Else
                    If Not strComment = "" Then
                        strComment = strComment & ", "
                    End If
                    strComment = strComment & c.Offset(0, 6).Value
            End Select
            Select Case c.Offset(0, 8).Value
                Case "---": strComment = strComment
                Case Else
                    If Not strComment = "" Then
                        strComment = strComment & ", "
                    End If
                    strComment = strComment & c.Offset(0, 8).Value
            End Select
            Select Case c.Offset(0, 10).Value
                Case "---": strComment = strComment
                Case Else
                    If Not strComment = "" Then
                        strComment = strComment & ", "
                    End If
                    strComment = strComment & c.Offset(0, 10).Value
            End Select
            Select Case c.Offset(0, 12).Value
                Case "---": strComment = strComment
                Case Else
                    If Not strComment = "" Then
                        strComment = strComment & ", "
                    End If
                    strComment = strComment & c.Offset(0, 12).Value
            End Select
            
            c.Value = strComment
        Next c
        
        'Overtollige velden in lithologie tabblad wissen
        .Range("F:S").Select
        .Selection.Delete Shift:=xlToLeft
        
        'Cursor terug naar home en cut/copy mode uitschakelen
        .CutCopyMode = False
        objXLWorksheet3.Select
        .Range("A1").Select
        .Range("A1").Activate
        objXLWorksheet2.Select
        .Range("A1").Select
        .Range("A1").Activate
        
        'Workbook opslaan als excelsheet
        .Workbooks(.Workbooks.Count).SaveAs FileName:=(Pad & "DINO-boringen_xls_voor_import\" & Left(.Workbooks(.Workbooks.Count).Name, Len(.Workbooks(.Workbooks.Count).Name) - 4)), FileFormat:=-4143, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
        
        'Worksheets en workbook sluiten
        Set objXLWorksheet2 = Nothing
        Set objXLWorksheet3 = Nothing
        .Workbooks(.Workbooks.Count).Close SaveChanges:=False
        Set objXLWorkbook = Nothing
        
        'Voortgang instellen en formulier verversen
        Forms!frmVoortgangConversieDINO_Rockware.txtVoortgang.Width = dblVoortgangMax * i / UBound(Bestandsnaam) 'Lengte blauwe balk instellen
        Forms!frmVoortgangConversieDINO_Rockware.lblVoortgang.Caption = "(" & i & " van " & UBound(Bestandsnaam) & " bestanden geconverteerd)" 'Label aantal bestanden aanpassen
        Forms!frmVoortgangConversieDINO_Rockware.lblPercentage.Caption = Round(100 * i / UBound(Bestandsnaam), 0) & "%" 'Percentage instellen
        Forms!frmVoortgangConversieDINO_Rockware.Repaint
    Next i
    
    DoCmd.Close acForm, "frmVoortgangConversieDINO_Rockware", acSaveNo
    
End With

objXLapp.Parent.Quit
objXLapp.Quit
Set objXLapp = Nothing

End Sub

In the Beginning there was nothing, which exploded.

--Terry Pratchett, Lords and Ladies--

 

[Thingol]

Hi!

Never mind! I spotted the error. It's in the line:

.Cells.Find( .... After:=ActiveCell .... )

This sould have been:

.Cells.Find( .... After:=[highlight].[/highlight]ActiveCell .... )

So I did have unqualified references

Best regards,
Martijn Senden.

In the Beginning there was nothing, which exploded.

--Terry Pratchett, Lords and Ladies--