Klasördeki Excel Dosyalarından Toplu Veri Çekme

[DeRBeDeR©]

Öncelikle herkese merhaba,

Ben İnşaat malzemeleri satan bir şirkette çalışıyorum. Mevcut hesapları ekte gönderdiğim şekilde tutuyorum. Bu şekilde yüzlerce müşteri excel dosyası mevcut. Benim yapmak istediğim bir tane excel tablosu yaparak klasör içindeki bütün excel dosyaların bakiyeleri çekmek yani "H3" hücresini. Müşterinin ismi yani excel dosya ismini veya "C3" hücresinin ismini yazacak yanınada bakiyesini yani "H3" hücresindeki borcunu yazacak.

Bunları otomotik olarak çekebileceğim bir formül varmıdır. Ayrıca her sildiğim veya taşıdığım excel dosyasıda burdan silinecek eklediğim her excel dosyasıda otomotik eklenecek. Böylece toplu bir şekilde alıp - vereceğimizi kontrol edebiliriz.

Yardımcı olabilirseniz çok makbule geçer. Şimdiden çok teşekkürler.

 

[DeRBeDeR©]

Zor birşey istedim sanırım )

Yanlış anlaşılmasın Zor olduğunun farkındayım.

 

[Murat OSMA]

Şu kodları deneyiniz;

Sub Emre()
    Dim Con As Object, Rs As Object, Fso As Object, Klasor As Object, Dosyalar As Object
    Dim Sorgu As String, Yol As String, Dosya As String
    Dim Sutun As Integer
    Set Con = CreateObject("AdoDb.Connection")
    Set Rs = CreateObject("AdoDb.RecordSet")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Yol = ThisWorkbook.Path
    Set Klasor = Fso.GetFolder(Yol)
    Cells.ClearContents
    Sutun = 1
    For Each Dosyalar In Klasor.Files
    If Dosyalar.Name <> "ANA DOSYA.xls" Then
    Dosya = Replace(Dosyalar.Name, ".xls", "")
    Con.Open "Provider=Microsoft.jet.OleDb.4.0;Data Source=" & _
    ThisWorkbook.Path & "\" & Dosya & ".xls" & _
    ";Extended Properties=""Excel 8.0;HDR=NO"""
    Sorgu = "Select F8 FROM [Satışlar$] where not isnull(F8)"
    Rs.Open Sorgu, Con, 1, 3
    Cells(1, Sutun) = Dosya
    Cells(2, Sutun).CopyFromRecordset Rs
    Rs.Close
    Con.Close
    Sutun = Sutun + 1
    End If
    Next Dosyalar
    Rows(3).ClearContents
    Set Con = Nothing: Set Rs = Nothing: Set Fso = Nothing
    Set Klasor = Nothing: Set Dosyalar = Nothing
    Yol = vbNullString: Dosya = vbNullString
End Sub

Dosyayı da ekliyorum...

 

[DeRBeDeR©]

Kodları nereye yazıyoruz?

 

[DeRBeDeR©]

Hocam Satışlar bulunamadı diye hata verdi. Bende koddan xls yazılan yerleri xlsx olarak değiştirdim çünkü bütün dosyalar xlsx bu seferde dış tablo bulunamadı diye hata verdi.

Office 2010 kullanıyorum.

Bu arada çok teşekkür ederim ilgin ve alakan için.

Son olarak üstten sağa doğru sıralıyor. Bunu A sütununa ADINI - B sütunada Bakiyesini yazarak aşağıya doğru sıralayabilirmiyiz?

 

[Murat OSMA]

Örnek dosya yolladım. ALT+F11 tuşlarına basın Module1 içersinde kodları göreceksiniz...


Dilerseniz şu kodları da kullanabilirsiniz;

Excel dosyalarının içinde bulunduğu Klasör adını şu satırdaki yerine yazınız;
For Each Dosya In Fso.GetFolder("C:\Documents and Settings\Murat OSMA\Desktop\2012 DEFTER_1").Files

Sub Emre()
    Dim Fso As Object, Dosya As Object
    Application.ScreenUpdating = False
    Set Fso = CreateObject("scripting.filesystemobject")
    For Each Dosya In Fso.GetFolder("C:\Documents and Settings\Murat OSMA\Desktop\2012 DEFTER_1").Files
    If Fso.GetExtensionName(Dosya.Path) = "xls" Then
        If Dosya.Name <> "ANA DOSYA.xls" Then
        Range("A65536").End(3)(2, 1) = Dosya.Name
        Set w = Workbooks.Open(Dosya.Path)
            If w.ReadOnly Then
                MsgBox Dosya.Path & " salt okunur olduğu için değişiklik yapılmadı"
            Else
            For Each sh In w.Worksheets
                sh.Range("H3").Copy
                Workbooks.Item(1).Activate
                Range("B65536").End(3)(2, 1).PasteSpecial xlPasteValues
            Next
        w.Save
            End If
        w.Close
        Set w = Nothing
        End If
    End If
    Next Dosya
    Application.ScreenUpdating = True
    Set Fso = Nothing
End Sub

Örnek dosyayı da ekliyorum...

 

[baydeniro]

Sayın Murat Osma çok teşekkürler.

 

[Murat OSMA]

Rica ederim Serdar Bey...

 

[DeRBeDeR©]

Ya hata alıyorum yada yanlış sonuç buluyor. Uğraşıp çözmem gerek.

Birde siz kodları xls olarak yazmışsınız fakat dosyalar xlsx. Bende xlsx olarak düzenledim. İlk mesajınızdaki kodlar çok güzeldi otomotik siliyordu - ekliyordu veya değiştiriyordu bana o lazım tam olarak. Ama o da hata verip duruyor.

Çok teşekkürler hem ilginize hemde harcadığınız zamana.

 

[Murat OSMA]

Dosyaları 2003 (xls) olarak kaydedip kodları o şekilde düzenlemiştim.
Eğer sizin kullandığınız orjinal dosyaları 2003 (xls) formatında kaydederseniz hiç bir sorun yaşamazsınız..


xlsx formatında kodları tekrar düzenledim. İki şekilde dosyalarınızı ekliyorum.
Deneyiniz...

 

[DeRBeDeR©]

Çok teşekkürler Üstat, eline koluna sağlık..

Allah razı olsun....

 

[Murat OSMA]

Rica ederim, iyi günler...