Klasördeki tüm excel dosyalarının belirli hücre aralıklarını bir dosyada kopyalama

[CENGAVER1]

Merhaba sayın üstatlar,

Benim için zor, sizin için ise çok kolay olacağını düşündüğüm bir soru.
Farklı konularda benzer sorular mevcut, ancak bu soru bulduğum 2 ayrı makronun birleşimi olduğu için yapamadım
Bir klasördeki tüm excel dosyalarının belirli bir aralığının (mesela A1-H24) alt alta bir dosyaya kopyalamasına ihtiyacım var.
Bu hücre aralığını makro başlamadan sorarak alırsa daha fonksiyonel olabilir.
Bu konu hakkındaki değerli yardımlarınızı arz ederim.

Saygılarımla

 

[Erdem Akdemir]

Merhaba,

Excel' ler kaç sayfadan oluşuyor.
Excel dosyalarının sayfa isimleri aynı mı?

 

[Erdem Akdemir]

Dosya isimleri sayfa1 ve verileri çekeceğiniz excel dosyası aynı klasörde olması şartı ile aşağıdaki kodu kullanabilirsiniz.
Diğer şartlara göre kod revize edilebilir.

Sub getir()

    Set con = VBA.CreateObject("adodb.Connection")
   Set cat = CreateObject("ADOX.Catalog")

'Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
    Cells.ClearContents

    Dim bir As Object
    Set bir = CreateObject("scripting.filesystemobject")
    yol = ThisWorkbook.Path
    Set klasor = bir.getfolder(yol)
    For Each dosyalar In klasor.Files
    If Not dosyalar.Name Like "*xlsm*" Then
    If dosyalar.Name Like "*xls*" Then

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & "\" & dosyalar.Name & ";extended properties=""Excel 12.0;hdr=yes"""

cat.ActiveConnection = con
syf = Replace(cat.tables.Item(0).Name, "'", "")

sorgu = "select * from[" & syf & "A1:H20]"
Set rs = con.Execute(sorgu)
son = Cells(Rows.Count, "a").End(3).Row + 1
Range("A" & son).CopyFromRecordset rs
con.Close
        End If
        End If
    Next
End Sub

 

[CENGAVER1]

Erdem bey,
yazdığınız kod çalışıyor ancak kitlenme yaşadığım için sadece bi kaç sorum olacak
1-xlsx olmayan dosyalarda sorun olur mu, klasörde xlsx ve xls olan dosyalar var
2-sayfa adları aynı tüm dosyalarda, ancak arada boşluk var nasıl düzetlmem gerekir "xxx xxx" şeklinde mi yoksa "xxx_xxx" gibi mi?
3-klasördeki tüm dosyalar dediğimizde çalıştığımız dosyaya da işlem yapmıyor mu?
Yardımlarınız için şimdiden teşekkür ederim

 

[Erdem Akdemir]

Merhaba,

Kodu güncelledim. xls ve xlsx uzantılı dosyalardaki verileri alacak. Sayda isimlerinde boşluk olması önemli değil.

 

[CENGAVER1]

Erdem bey, kod harika hiçbir sorun yok,
bir sorum daha olsa zahmet olur mu acaba,
bundan sonra gelecek dosyalarda sayfa ismi şartını kaldırabilir miyiz?
mesela her dosyanın ilk sayfası yapabilir miyiz kodu?
yoksa illa bi isim gerekir mi?

 

[Erdem Akdemir]

Merhaba,

Kodu güncelledim. Excel dosyalarının ilk sayfasını alacak.

 

[Haluk]

İlave bilgi:

Erdem Beyin ADO kullanımına alternatif olarak eğer DAO kullansaydık, kapalı dosyanın ilk sayfasından veri almak için "TableDefs" özelliğini kullanabilirdik...

            Set DB = daoDBEngine.OpenDatabase(myFile, False, False, "Excel 8.0; HDR=Yes; IMEX=1;")
            myTable = DB.TableDefs(0).Name
            Set RS = DB.OpenRecordset("Select * from [" & myTable & "A1:H20]")

 

[CENGAVER1]

Haluk bey,size de cevabınız için çok teşekkürler, farklı dosya tiplerinde çalışmak istersek DAO da işimize yarayabilir.

Erdem bey bu sefer böyle bir hata verdi, bir önceki kod gayet güzel çalışırken
https://ibb.co/mbkQxv6

farklı farklı dosyalarla denedim, hangisinin ilk sayfa adı neyse öyle hatada o dosya adını bulamadığını söyledi nedense.
hataya gittiğimde
Set rs = con.Execute(sorgu) satırını refere ediyor

 

[Erdem Akdemir]

Hata veren dosyayı görmeden yorum yapamam.

 

[CENGAVER1]

Hocam dosya farketmiyor her dosyada aynı hatayı veriyor. Önceki sayfa ismi yazdığımız sorunsuz çalışıyor ama.
Örnek bi dosya ekledim yine de

http://s000.tinyupload.com/index.php?file_id=09786788004463228494

 

[Erdem Akdemir]

Merhaba,

Örnek dosyanızda sayfa adını alırken tek tırnak ekliyor.

Kodun aşağıdaki kısmını değiştirin. Mevcut kodu'da güncelledim.

syf = Replace(cat.tables.Item(0).Name, "'", "")

 

[CENGAVER1]

Erdem bey kusura bakmayın bugün dönüş yapamadım,
pazartesi işyerinde ilk iş test edip dönüş yapacağım
iyi haftasonları dilerim

 

[CENGAVER1]

Erdem bey, elinize sağlık çok teşekkür ederim.
kod çok güzel çalışıyor.
Ben size bi jest yapmak istesem mümkün mü acaba?

 

[Erdem Akdemir]

Cengaver bey,

Teşekkür etmeniz yeterli.

İyi çalışmalar.

 

[CENGAVER1]

Tekrar çok teşekkürler
elinize sağlık

 

[m.ensar]

Erdem Hocam belki konu kapanmıştır ama yine de teşekkür ederim bu vermiş olduğun kod çok güzel günlerdir uğraştığım kitaplar arası veri aktarmayı bununla çözdüm. Allah razı olsun

 

[m.ensar]

Üstadım Tek Sayfa lı kitaplarda problem yok ama çalışma kitabında sayfa 1 sayfa 2 sayfa 3 gibi sayfalar olduğun da kod SAYFA2 den veri çekiyor bunu sadece sayfa birden çekecek şekilde nasıl düzenleriz? yardımcı olabilir misin?