• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kapalı dosyadan veri çekmek

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
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
 

Ekli dosyalar

Deneyiniz.

C++: 
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
 
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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
Genişletmek için tıkla ...
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"";"
 
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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
Genişletmek için tıkla ...
 
Küçük bir düzeltme yaptım. Kodu tekrar deneyiniz.
 
Bu satırı silerseniz düzelir.

ActiveWindow.DisplayGridlines = False
 
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
Genişletmek için tıkla ...
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst