Birden Çok Dosyadan Aynı Verileri Çekme

  • Konuyu başlatan Konuyu başlatan HasanRe
  • Başlangıç tarihi Başlangıç tarihi
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Katılım
28 Tem 2022
Mesajlar
7
Excel Versiyonu
Excel 2016
Excel Sürümü
64 Bit
Excel Dili
Türkçe
Mrb forum sakinleri, ben bir evrak için excelde çözüm arıyorum, şöyle ki yaklaşık 100 excel tablosundan belirli bir hücrenin versini cekip dosyanın adına göre sıralasın istiyorum.

örnek olarak verinin çekileceği bir dosyayı yükledim. ( mesela 1 temmuz nolu dosyadan ali adlı kişinin verisi her dosyada d2 olarak geçmekte bunun verisini cekince onu belirtsin 1 temmuz [d2] şeklinde veya alt alta da yazabilir. (hepsi birbirinin aynı dosyalar)
 

Ekli dosyalar

  • 1.xlsx
    1.xlsx
    11.3 KB · Görüntüleme: 6
Çözüm
Çalışma dosyanda Sütün başlıklarını ali - veli - ahmet şeklinde yaparsan sağlıklı alabilirsin. Ona göre çalışma sayfanı düzenleyip atarsan, incelerim.
Yok diyorsan ki her personelin hücresi bütün dosyalarda aynı yerleri değişmiyor aynı dersen.
Aşağıdaki kodu kullan.

CSS:
Sub Dosyalar_Ado()
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
Set cat = CreateObject("adox.catalog")
Set tbl = CreateObject("adox.table")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Klasor = Fso.GetFolder(ThisWorkbook.Path)
    sat = 6
    For Each dosyalar In Klasor.Files
    If dosyalar.Name <> ThisWorkbook.Name Then
    If Left(dosyalar.Name, 1) <> "~" Then
        con.Open "provider=microsoft.ace.oledb.12.0;data...
daha açıklayacı olayım hocam ; elımde 12 aya ait ( ocak,şubat ...) excel dosyası var hepsnin formatı aynı yukarda örnek bir tane yükledim, benim istediğim bir makro veya fonksiyon ile mesela her bir dosyadan bana D2 verisini geitirip hangi dosyadan getirdiyse dosya ismi+D2 verisi şeklinde sunması, örnek : "(ay)Temmuz : (D2 verisi)HM-2 " şeklinde
 
teşekkür ederim Feyzullah bey vakit ayırıp cevap yazdığınız için detaylı dosyaların hepsini attım içinde resimli açıklama mevcut tam bir örnek oluşsun diye.
Ben makro ile veri çekmeye çalışıyordum lakin biraz karışık geldi içinden çıkamadım :/
 

Ekli dosyalar

VBA:
Sub Dosyalar_Ado()
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
Set cat = CreateObject("adox.catalog")
Set tbl = CreateObject("adox.table")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Klasor = Fso.GetFolder(ThisWorkbook.Path)
    sat = 6
    For Each dosyalar In Klasor.Files
    If dosyalar.Name <> ThisWorkbook.Name Then
    If Left(dosyalar.Name, 1) <> "~" Then
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosyalar & ";extended properties=""Excel 12.0;imex=1;hdr=no"""
        cat.activeconnection = con
        sayfa = Replace(cat.tables(0).Name, "'", "")
            sorgu = "select f4 from [" & sayfa & "] where f1 = 'ALİ'  "
            rs.Open sorgu, con, 1, 1
                If rs.RecordCount > 0 Then
                sat = sat + 1
                Cells(sat, 2) = Replace(dosyalar.Name, ".xlsx", ":") & rs(0).Value
                End If
        rs.Close: con.Close
    End If
    End If
    Next
Set rs = Nothing: Set con = Nothing
MsgBox "işlem tamam", vbInformation + vbMsgBoxRtlReading, "Tamam"
End Sub
 
Allah sizden razı olsun hocam, attığınız mükemmel çalışıyor , ayrıca bende bu konu hakkında kendimi geliştirecem gerçekten excel çok keyifli bir konu
 
Feyzullah bey sizi rahatsız ediyorum ama ufak bir geliştirme sorabilir miyim? bu attığınız kodda nasıl bir değişiklik yaparsak ;

Alinin verilerini alt alta çekiyor ya , hemen 2 yan sutuna da diğer ismin verilerini alt alta çeksin böyle böyle ordaki isimlerin verilerini stun stun yan yana getirse?
 
Çalışma dosyanda Sütün başlıklarını ali - veli - ahmet şeklinde yaparsan sağlıklı alabilirsin. Ona göre çalışma sayfanı düzenleyip atarsan, incelerim.
Yok diyorsan ki her personelin hücresi bütün dosyalarda aynı yerleri değişmiyor aynı dersen.
Aşağıdaki kodu kullan.

CSS:
Sub Dosyalar_Ado()
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
Set cat = CreateObject("adox.catalog")
Set tbl = CreateObject("adox.table")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Klasor = Fso.GetFolder(ThisWorkbook.Path)
    sat = 6
    For Each dosyalar In Klasor.Files
    If dosyalar.Name <> ThisWorkbook.Name Then
    If Left(dosyalar.Name, 1) <> "~" Then
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosyalar & ";extended properties=""Excel 12.0;imex=1;hdr=no"""
        cat.activeconnection = con
        sayfa = Replace(cat.tables(0).Name, "'", "")
            sorgu = "select f1 from [" & sayfa & "D7:D]  "
            rs.Open sorgu, con, 1, 1
                If rs.RecordCount > 0 Then
                sat = sat + 1
                sut = 1
                Do While Not rs.EOF
                    sut = sut + 1
                    Cells(sat, sut) = rs(0).Value
                rs.movenext
                Loop
                End If
        rs.Close: con.Close
    End If
    End If
    Next
Set rs = Nothing: Set con = Nothing
MsgBox "işlem tamam", vbInformation + vbMsgBoxRtlReading, "Tamam"
End Sub
 
Çözüm
evet hocam hepsinde aynı değişmiyor , kodunuz akan bir su kadar berrak çalıştı :) çok teşekkür ederim gerçekten. iki kodunuzu da kendimi geliştirmek içinde inceleyecem detaylı :)
 
İyi çalışmalar, Makroyu öğrenmeye başladı iseniz bırakmayın devam edin. Bu benim yazdığım iki kod ADO makro kodu olarak geçer, burada önemli olan sorgu kodudur.
 
Evet öğrenmeye çalışıyorum çok keyifli gerçekten bulmaca gibi, özellikle bu dediğiniz ado makro çok ilgi çekici inşallah çok ileriye gidene dek devam edecem
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Benzer Konular Popüler İçerikler Daha Fazlası
Geri
Üst Alt