Kapalı dosyadan veri çekmek

[metin_0606]

Kapalı isimli çalışma kitabımın Sayfa1 nin W sütununda çalışma durumu "Etkin" olup T sütununda kimlik geçerlilik tarihi yazılı olanları (Çalışma durumu Etkin olup tarih yazmayanlar gelmeyecek); TC kimlik noları ve kimlik geçerlilik tarihlerini açık isimli çalışma kitabımın Sayfa1 nin B sütununa TC kimlik no C Sütununada Kimlik Geçerlilik tarihleri gelecek şekilde çekmek makro ile çekmek istiyorum. Yardımlarınız için şimdiden teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Kapali_Dosyadan_Verileri_Aktar()
    Dim Dosya_Yolu As String, S1 As Worksheet, Son As Long
    Dim Ado_Baglanti As Object, Kayit_Seti As Object, Sorgu As String
  
    Set Ado_Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Sayfa1")
  
    Dosya_Yolu = ThisWorkbook.Path & Application.PathSeparator & "kapalı.xlsx"
  
    S1.Select
    S1.Range("A2:C" & S1.Rows.Count).Clear
  
    Ado_Baglanti.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    Dosya_Yolu & ";Extended Properties = ""Excel 12.0 Xml;HDR=NO"";"
  
    Sorgu = "Select F2,F20 From [Sayfa1$] Where F23 = 'Etkin' And F20 Is Not Null "
  
    Kayit_Seti.Open Sorgu, Ado_Baglanti, 1, 1
  
    S1.Range("B2").CopyFromRecordset Kayit_Seti
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    S1.Range("A2") = 1
    S1.Range("A2").AutoFill Destination:=S1.Range("A2:A" & Son), Type:=xlFillSeries
    S1.Range("A1:C" & Son).Borders.LineStyle = 1
    S1.Columns.AutoFit
    ActiveWindow.DisplayGridlines = False
  
    Kayit_Seti.Close
  
    Set Kayit_Seti = Nothing
    Set Ado_Baglanti = Nothing
  
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

 

[metin_0606]

Deneyiniz.

Option Explicit

Sub Kapali_Dosyadan_Verileri_Aktar()
    Dim Dosya_Yolu As String, S1 As Worksheet, Son As Long
    Dim Ado_Baglanti As Object, Kayit_Seti As Object, Sorgu As String
  
    Set Ado_Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Sayfa1")
  
    Dosya_Yolu = ThisWorkbook.Path & Application.PathSeparator & "kapalı.xlsx"
  
    S1.Select
    S1.Range("A2:C" & S1.Rows.Count).Clear
  
    Ado_Baglanti.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    Dosya_Yolu & ";Extended Properties = ""Excel 12.0 Macro;HDR=NO"";"
  
    Sorgu = "Select F2,F20 From [Sayfa1$] Where F23 = 'Etkin' And F20 Is Not Null "
  
    Kayit_Seti.Open Sorgu, Ado_Baglanti, 1, 1
  
    S1.Range("B2").CopyFromRecordset Kayit_Seti
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    S1.Range("A2") = 1
    S1.Range("A2").AutoFill Destination:=S1.Range("A2:A" & Son), Type:=xlFillSeries
    S1.Range("A1:C" & Son).Borders.LineStyle = 1
    S1.Columns.AutoFit
    ActiveWindow.DisplayGridlines = False
  
    Kayit_Seti.Close
  
    Set Kayit_Seti = Nothing
    Set Ado_Baglanti = Nothing
  
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

Bu satırda hata verdi Korhan hocam
Ado_Baglanti.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _

Dosya_Yolu & ";Extended Properties = ""Excel 12.0 Macro;HDR=NO"";"

 

[metin_0606]

Deneyiniz.

Option Explicit

Sub Kapali_Dosyadan_Verileri_Aktar()
    Dim Dosya_Yolu As String, S1 As Worksheet, Son As Long
    Dim Ado_Baglanti As Object, Kayit_Seti As Object, Sorgu As String
  
    Set Ado_Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Sayfa1")
  
    Dosya_Yolu = ThisWorkbook.Path & Application.PathSeparator & "kapalı.xlsx"
  
    S1.Select
    S1.Range("A2:C" & S1.Rows.Count).Clear
  
    Ado_Baglanti.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    Dosya_Yolu & ";Extended Properties = ""Excel 12.0 Macro;HDR=NO"";"
  
    Sorgu = "Select F2,F20 From [Sayfa1$] Where F23 = 'Etkin' And F20 Is Not Null "
  
    Kayit_Seti.Open Sorgu, Ado_Baglanti, 1, 1
  
    S1.Range("B2").CopyFromRecordset Kayit_Seti
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    S1.Range("A2") = 1
    S1.Range("A2").AutoFill Destination:=S1.Range("A2:A" & Son), Type:=xlFillSeries
    S1.Range("A1:C" & Son).Borders.LineStyle = 1
    S1.Columns.AutoFit
    ActiveWindow.DisplayGridlines = False
  
    Kayit_Seti.Close
  
    Set Kayit_Seti = Nothing
    Set Ado_Baglanti = Nothing
  
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

Bölgesel dil seçeneği ingilizce olduğu için yapıyormuş Korhan bey sayfa ismini değiştirdim çalıştırdı teşekkürler ancak veri getirdiği yer hariç bütün klavuz çizgilerini kaldırdı buna bir çözüm bulabilirmiyiz

 

[Korhan Ayhan]

Küçük bir düzeltme yaptım. Kodu tekrar deneyiniz.

 

[Korhan Ayhan]

Bu satırı silerseniz düzelir.

ActiveWindow.DisplayGridlines = False

 

[metin_0606]

Bu satırı silerseniz düzelir.

ActiveWindow.DisplayGridlines = False

Çok teşekkür ederim Korhan hocam yine süpersin makro işimi tam anlamıyla gördü

 

[Hacı Bayram ÖZKAN]

Selamün Aleyküm arkadaşlar bu kodu kendime uyarladım; ama bir türlü yazmaya L18'den başlamıyor, dosyayı ekliyorum bakarsanız sevinirim. Benim Personel Listesi dosyam Standart Hepsi başlık hariç 2. satırdan başlıyor.

Sub BEN_HAZIRLADIM_TÜM_LİSTE()
Dim Dosya_Yolu As String, S1 As Worksheet, Son As Long
Dim Ado_Baglanti As Object, Kayit_Seti As Object, Sorgu As String

Set Ado_Baglanti = CreateObject("AdoDb.Connection")
Set Kayit_Seti = CreateObject("AdoDb.Recordset")
Set S1 = Sheets("LÜZUM ONAYI")

Dosya_Yolu = "E:\Belgelerim\Personel\PERSONEL LİSTESİ.xlsm"

S1.Select
S1.Range("K18:N" & S1.Rows.Count).Clear

Ado_Baglanti.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
Dosya_Yolu & ";Extended Properties = ""Excel 12.0 Macro;HDR=NO"";"

Sorgu = "Select F2,F3,F4 From [LİSTE$]"

Kayit_Seti.Open Sorgu, Ado_Baglanti, 1, 1

S1.Range("L18").CopyFromRecordset Kayit_Seti
Son = S1.Cells(S1.Rows.Count, 12).End(3).Row
S1.Range("K18") = 1
S1.Range("K18").AutoFill Destination:=S1.Range("K18:K" & Son), Type:=xlFillSeries
S1.Range("K17:N" & Son).Borders.LineStyle = 1
'S1.Columns.AutoFit
'ActiveWindow.DisplayGridlines = False

Kayit_Seti.Close

Set Kayit_Seti = Nothing
Set Ado_Baglanti = Nothing

MsgBox "PERSONEL LİSTESİ GÜNCELLENMİŞTİR.", vbInformation

End Sub