Kapalı Dosyadan veri alırken üzerine ekleme

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar, Siteden araştırarak ekli dosyamdaki kod ile kapalı dosyadan istediğim verileri alıyorum, ancak bunu bir dosyadan alabiliyorum. Benim istediğim, aynı formatta olan ve diğer dosyalardan da isteğime göre verileri almak istiyorum, yani kodu her çalıştırdığımda eski verilerin silinip silinmesini bana sormasını istiyorum, silinmesini istiyorsam, silerek yeni bir liste oluşturması, eğer silinmesini istemiyorsam önceki listenin devamında aynı formatla eklemesini istiyorum. ekli dosyamdaki TEK_HEKİM adlı kodda nasıl bir değişiklik yapılabilir. Teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Bu tarz sorularınızda veri alınacak dosyalardan da örnek paylaşırsanız destek vermek isteyenler deneme yapabilirler.

Kodlarınızı incelediğim kadarıyla dosyalarda SAĞLIK ismindeki sayfalardan veri almak istiyorsunuz.

 

[Hacı Bayram ÖZKAN]

Merhabalar; evet doğru sadece SAĞLIK sayfasından alacağım. Mevcut kodla alıyordum, diğer aylar için yani üstüne eklemek için lazımdı dosyadaki veriler hep aynı, onuda ekliyorum.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub TEK_HEKİM()
    Dim S1 As Worksheet, Baglanti As Object, Kayit_Seti As Object
    Dim Sayfalar As Object, X As Long, Dosya_Yolu As Variant
    Dim Sayfa As Object, Kontrol As Boolean, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("FORMAT")
    
    If MsgBox("Eski veriler silinsin mi?", vbCritical + vbYesNo + vbDefaultButton2, "Dikkat!") = vbYes Then
        S1.Range("A2:M" & S1.Rows.Count).ClearContents
    End If
    
    On Error Resume Next
    ChDrive "D"
    ChDir "D:\Belgelerim\Raporlar"
    On Error GoTo 0
    
    Dosya_Yolu = Application.GetOpenFilename(FileFilter:="Excel Dosyaları (*.xls;*.xlsx;*.xlsm),*xls;*.xlsm;*.xlsx", MultiSelect:=True)
    
    If Not IsArray(Dosya_Yolu) Then
        MsgBox "Dosya seçimi iptal edildi!", vbCritical
        Exit Sub
    End If
    
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Sayfalar = CreateObject("Adox.Catalog")
    
    For X = LBound(Dosya_Yolu) To UBound(Dosya_Yolu)
        Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
        Dosya_Yolu(X) & ";Extended Properties = ""Excel 12.0 Macro;Hdr=No"""
        
        Sayfalar.ActiveConnection = Baglanti
        
        For Each Sayfa In Sayfalar.Tables
            If InStr(1, Sayfa.Name, "SAĞLIK", vbTextCompare) <> 0 Then
                Kontrol = True
                Exit For
            End If
        Next
    
        If Kontrol = True Then
            Set Kayit_Seti = Baglanti.Execute("Select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F13 From [SAĞLIK$] Where F6 = 'Tek Hekim'")
            S1.Cells(S1.Rows.Count, 2).End(3)(2, 1).CopyFromRecordset Kayit_Seti
            Kayit_Seti.Close
        End If
        
        If Baglanti.State <> 0 Then Baglanti.Close
    Next
    
    S1.Range("A2") = 1
    S1.Range("A2").AutoFill Destination:=S1.Range("A2:A" & S1.Cells(S1.Rows.Count, "B").End(3).Row), Type:=xlFillSeries

    Set Baglanti = Nothing
    Set Sayfalar = Nothing
    Set S1 = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Hacı Bayram ÖZKAN]

Sayın abim çok güzel olmuş eline sağlık teşekkürler, Berat geceniz mübarek olsun