Excelden Veri Alırken Dosyanın Kapanmaması

Sayın hocalarım; aşağıdaki kod ile excelden veri alıyorum. Veri alama da sorun yok ancak her defasında Excel dosyasını açıyor ve alma işlemi bitince dosyayı kapatmıyor. Excel dosyasının kapanmasını nasıl sağlayabilirim acaba?

Private Sub EXCELDENAL_Click()

Dim fDialog As Office.FileDialog

Dim varFile As Variant

Dim dosya As String

On Error GoTo EXCELDENAL_Err



Set fDialog = Application.FileDialog(msoFileDialogFilePicker)



With fDialog

.AllowMultiSelect = False

.title = "Lütfen Aktaracağınız Bilgilerin Bulunduğu Excel Dosyasını Seçin"

.Filters.Clear

.Filters.Add "Excel 2003", "*.xls"

.Filters.Add "Excel 2007", "*.xlsx"

.Filters.Add "All Files", "*.*"



If .show = True Then



For Each varFile In .SelectedItems



dosya = varFile

Dim sonsatirno As Integer

Dim crt As Long

Dim kacadet, strSinifAdi, strtoplam As Integer

Dim strkriter, strokulturu, strSubeAdi As String



Dim xlApp As Excel.Application

Dim xlBook As Excel.Workbook



Set xlApp = CreateObject("Excel.Application")

Set xlBook = xlApp.Workbooks.Open(dosya)

Set xlSheet = xlBook.Worksheets(1)



'Dim myRec As DAO.Recordset

sonsatirno = xlSheet.Range("A65536").End(xlUp).Row

Debug.Print sonsatirno

'Set myRec = CurrentDb.OpenRecordset("Tbl_Gider")



For I = 8 To sonsatirno

If xlSheet.Cells(I, "D") >= 0 Then

'MsgBox crt & " " & " bu gider değil"

Else



strSQL = "SELECT * FROM Tbl_Gider "

Set rstkayit = New ADODB.Recordset

rstkayit.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

With rstkayit

kriterim = xlSheet.Cells(I, "B") & "-" & xlSheet.Cells(I, "A")

.Find "[kriter]=" & "'" & kriterim & "'"

If Not rstkayit.EOF Then



.Fields("Tarih") = xlSheet.Cells(I, "A")

.Fields("FisNo") = xlSheet.Cells(I, "B")

.Fields("GiderAciklamasi") = xlSheet.Cells(I, "C")

.Fields("Tutar") = Mid((xlSheet.Cells(I, "D")), 2, ((Len(xlSheet.Cells(I, "D")) - 1)))

.Fields("ay") = Format$(xlSheet.Cells(I, "A"), "mmmm")

.Fields("Yil") = Format$(xlSheet.Cells(I, "A"), "yyyy")

'.Fields("kriter") = xlSheet.Cells(I, "B") & "-" & xlSheet.Cells(I, "A")



kacadet = kacadet + 1

lbxData.Requery

.Update

Else

.AddNew

.Fields("Tarih") = xlSheet.Cells(I, "A")

.Fields("FisNo") = xlSheet.Cells(I, "B")

.Fields("GiderAciklamasi") = xlSheet.Cells(I, "C")

.Fields("Tutar") = Mid((xlSheet.Cells(I, "D")), 2, ((Len(xlSheet.Cells(I, "D")) - 1)))

.Fields("ay") = Format$(xlSheet.Cells(I, "A"), "mmmm")

.Fields("Yil") = Format$(xlSheet.Cells(I, "A"), "yyyy")

.Fields("kriter") = xlSheet.Cells(I, "B") & "-" & xlSheet.Cells(I, "A")



kacadet = kacadet + 1

lbxData.Requery

.Update

End If

End With

End If



Next

xlApp.Visible = True

xlBook.Close

xlApp.Quit



Set xlApp = Nothing

Set xlBook = Nothing

lbxData.Requery

If kacadet > 0 Then MsgBox kacadet & " " & "Yeni Kayıt Eklendi"







Next

Else

MsgBox "Vazgeçildi."

End If

End With

EXCELDENAL_Exit:

Exit Sub

EXCELDENAL_Err:

MsgBox Error$

Resume EXCELDENAL_Exit

Merhaba.

xlApp.Visible = True

kodu fazladan. Devamındaki kodların da

  xlBook.Close True

    

    Set xlSheet = Nothing

    Set xlBook = Nothing

    

    xlApp.Quit

    

    Set xlApp = Nothing

şeklinde deneyiniz.

Hocam; teşekkür ederim ellerinize sağlık.

Merhaba,


Kodun son halini yazar mısınız?

Private Sub EXCELDENAL_Click()



On Error GoTo EXCELDENAL_Err

 Dim fDialog As Office.FileDialog

    Dim varFile As Variant

    Dim dosya As String

   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)



   With fDialog

      .AllowMultiSelect = False

      .title = "Lütfen Aktaracağınız Bilgilerin Bulunduğu Excel Dosyasını Seçin"

      .Filters.Clear

      .Filters.Add "Excel 2003", "*.xls"

      .Filters.Add "Excel 2007", "*.xlsx"

      .Filters.Add "All Files", "*.*"

      

      If .show = True Then

      

    For Each varFile In .SelectedItems

         

    dosya = varFile

    Dim sonsatirno As Integer

    Dim crt As Long

    Dim kacadet, Guncel, Yeni As Integer

    Dim strkriter, strokulturu, strSubeAdi As String

    

    Dim xlApp As Excel.Application

    Dim xlBook As Excel.Workbook

    

    Set xlApp = CreateObject("Excel.Application")

    Set xlBook = xlApp.Workbooks.Open(dosya)

    Set xlSheet = xlBook.Worksheets(1)

    

    sonsatirno = xlSheet.Range("A65536").End(xlUp).Row

    Debug.Print sonsatirno



    For I = 8 To sonsatirno

     If xlSheet.Cells(I, "A") <= 0 Then

                 'MsgBox crt & " " & " bu Gelir değil"

        Else

        If xlSheet.Cells(I, "D") <= 0 Then

                 'MsgBox crt & " " & " bu Gelir değil"

        Else

              

    strSQL = "SELECT * FROM Tbl_Gelir "

    Set rstkayit = New ADODB.Recordset

    rstkayit.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

    With rstkayit

    kriterim = xlSheet.Cells(I, "B") & "-" & Format$(xlSheet.Cells(I, "A"), "gg.mm.yyyy")

        .Find "[kriter]=" & "'" & kriterim & "'"

    If Not rstkayit.EOF Then



        .Fields("Tarih") = xlSheet.Cells(I, "A")

        .Fields("FisNo") = xlSheet.Cells(I, "B")

        .Fields("GelirAciklamasi") = xlSheet.Cells(I, "C")

        .Fields("Tutar") = xlSheet.Cells(I, "D")

        .Fields("ay") = Format$(xlSheet.Cells(I, "A"), "mmmm")

        .Fields("Yil") = Format$(xlSheet.Cells(I, "A"), "yyyy")

        '.Fields("kriter") = xlSheet.Cells(I, "B") & "-" & xlSheet.Cells(I, "A")



    Guncel = Guncel + 1

    lbxData.Requery

        .Update

    Else

        .AddNew

        .Fields("Tarih") = xlSheet.Cells(I, "A")

        .Fields("FisNo") = xlSheet.Cells(I, "B")

        .Fields("GelirAciklamasi") = xlSheet.Cells(I, "C")

        .Fields("Tutar") = xlSheet.Cells(I, "D")

        .Fields("ay") = Format$(xlSheet.Cells(I, "A"), "mmmm")

        .Fields("Yil") = Format$(xlSheet.Cells(I, "A"), "yyyy")

        .Fields("kriter") = xlSheet.Cells(I, "B") & "-" & xlSheet.Cells(I, "A")



    Yeni = Yeni + 1

    lbxData.Requery

        .Update

    End If

    End With

    End If

End If

                Next

            xlApp.Visible = False



            xlBook.Close True

    

            Set xlSheet = Nothing

            Set xlBook = Nothing

    

            xlApp.Quit

    

            Set xlApp = Nothing



                lbxData.Requery

            If Guncel > 0 And Yeni = 0 Then

                MsgBox Guncel & " " & " Kayıt Güncellendi"

            ElseIf Guncel = 0 And Yeni > 0 Then

                 MsgBox Yeni & " " & "Yeni Kayıt Eklendi"

            End If

                

                

         Next

      Else

         MsgBox "Vazgeçildi."

      End If

   End With

EXCELDENAL_Exit:

    Exit Sub



EXCELDENAL_Err:

    MsgBox Error$

    Resume EXCELDENAL_Exit



End Sub

Kodun son hali.