Excelden Veri Alırken Dosyanın Kapanmaması

24/10/2017, 23:28

idrisy

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
25/10/2017, 01:32

ozanakkaya

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.
26/10/2017, 22:17

idrisy

Hocam; teşekkür ederim ellerinize sağlık.
27/10/2017, 10:37

ozanakkaya

Merhaba,


Kodun son halini yazar mısınız?
30/10/2017, 16:54

idrisy

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.