Skip to main content

AccessTr.neT


Excelden Veri Alırken Dosyanın Kapanmaması

Excelden Veri Alırken Dosyanın Kapanmaması

Çözüldü #1
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?



Visual Basic Code
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
Cevapla
#2
Merhaba.

Visual Basic Code
xlApp.Visible = True


kodu fazladan. Devamındaki kodların da

Visual Basic Code
  xlBook.Close True
    
    Set xlSheet = Nothing
    Set xlBook = Nothing
    
    xlApp.Quit
    
    Set xlApp = Nothing


şeklinde deneyiniz.
Cevapla
#3
Hocam; teşekkür ederim ellerinize sağlık.
Cevapla
#4
Merhaba,


Kodun son halini yazar mısınız?
Cevapla
#5
Visual Basic Code
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.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task