Kapalı dosyadan veri alınırken eskilerin silinip silinmemesi . . .

[Hacı Bayram ÖZKAN]

İyi akşamlar; 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 kodda nasıl bir değişiklik yapılabilir. Teşekkür ederim.

Sub TEK_HEKİM()

Dim s1 As Worksheet
Dim con, rcd
Dim x As Long

Dim dosyayolu '*****************

Set s1 = Sheets("FORMAT")

If MsgBox("Eski veriler silinsin mi?", vbCritical + vbYesNo + vbDefaultButton2, "Dikkat!") _
= vbYes Then Range("A2:M" & Rows.Count).ClearContents

'İkinci dosyadan veriler alınırken, isteğe göre silinip silinmemesi için ek.

'*********************
ChDrive "D"
ChDir "D:\Belgelerim\Raporlar"
dosyayolu = Application.GetOpenFilename(FileFilter:="Excel Dosyaları (*.xls;*.xlsx;*.xlsm),*xls;*.xlsm;*.xlsx")
If dosyayolu = False Then MsgBox "DOSYA SEÇİMİ İPTAL EDİLDİ": Exit Sub
'****************************
'****************************
Set con = CreateObject("Adodb.Connection")
Set rcd = CreateObject("adodb.recordset")
'/////////////////////////////////////////////
Set sayfalar = CreateObject("ADOX.Catalog")
'/////////////////////////////////////////////

s1.Range("A2:M" & Rows.Count) = Empty
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
dosyayolu & ";Extended Properties = ""Excel 12.0 Macro;HDR=No;ReadOnly=True;IMEX=1"";"
'/////////////////////////////////////////////
sayfalar.ActiveConnection = con
For Each sayfa In sayfalar.Tables
sad = sad & sayfa.Name
Next
'///////////////////////////////////////////////
If InStr(1, sad, "SAĞLIK", vbTextCompare) <> 0 Then
'///////////////////////////

rcd.Open "SELECT F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F13 FROM [SAĞLIK$] Where F6 = 'Tek Hekim'", con
s1.Range("B2").CopyFromRecordset rcd
s1.Range("B2:M2").Delete Shift:=xlUp
rcd.Close

'---------------------------
Else
MsgBox "Sayfa adını Kontrol Edin, SAĞLIK adı altında ve Büyük Harf olmalı."
Exit Sub
End If


'...........................METİN OLARAK ALINAN SÜTUNLAR TARİH ve SAYIYA ÇEVİRİLECEK...............
Dim rt As Variant, g As Long
MsgBox "Kontrol Yapıldı, Metin olan Tarih ve sayılar Çevrilecek"
rt = Array("7", "8", "9")
For g = 0 To UBound(rt)
s1.Columns(CDbl(rt(g))).TextToColumns Destination:=s1.Cells(1, CDbl(rt(g))), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
Next
'............................................
rt2 = Array("2", "11", "12")
For g = 0 To UBound(rt2)
s1.Columns(CDbl(rt2(g))).TextToColumns Destination:=s1.Cells(1, CDbl(rt2(g))), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Next

x = s1.Cells(Rows.Count, "B").End(3).Row
s1.[A2] = "1"
s1.[A2].AutoFill Destination:=Range("A2:A" & x), Type:=xlFillSeries

End Sub

 

[Hacı Bayram ÖZKAN]

Bu dosyam için küçük bir yardım istiyorum teşekkürler

 

[Hacı Bayram ÖZKAN]

.

 

[Hacı Bayram ÖZKAN]

Sayın abilerim bu dosyama bir bakar mısınız?