+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Access (https://accesstr.net/forum-microsoft-access.html)
+--- Forum: Access Cevaplanmış Soruları (https://accesstr.net/forum-access-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Excelden Veri Alırken Dosyanın Kapanmaması (/konu-excelden-veri-alirken-dosyanin-kapanmamasi.html)
Excelden Veri Alırken Dosyanın Kapanmaması - idrisy - 24/10/2017
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_ExitCvp: Excelden Veri Alırken Dosyanın Kapanmaması - ozanakkaya - 25/10/2017
Merhaba.
xlApp.Visible = Truekodu fazladan. Devamındaki kodların da
xlBook.Close True
Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothingşeklinde deneyiniz.
Cvp: Excelden Veri Alırken Dosyanın Kapanmaması - idrisy - 26/10/2017
Hocam; teşekkür ederim ellerinize sağlık.
Cvp: Excelden Veri Alırken Dosyanın Kapanmaması - ozanakkaya - 27/10/2017
Merhaba,
Kodun son halini yazar mısınız?
Cvp: Excelden Veri Alırken Dosyanın Kapanmaması - idrisy - 30/10/2017
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 SubKodun son hali.