Klasör içerisindeki
Excel dosyalarını tek dosyada birleştirmek istiyorum. ADO yöntemi kullanılan dosyaları indirip uyarlamaya çalıştım ama bir türlü birleştiremedim. ADO yöntemi ile kapalı dosyalardan verileri tek dosyaya toplayabilir miyiz?
Kriterler
1 - BİRİM (1).............BİRİM (50) ye kadar 50 adet bir klasör içerisinde dosyam var.
2 - Kapalı olan BİRİM (1)........BİRİM (50) ye kadar xlsm dosyalarından 00 - Tüm Veri Dosyası"na verileri çekmek istiyorum.
3 - Dosya içerisindeki formatlar aynıdır. Sütunlar sabit olup satırlara girilen veriler değişebiliyor. 5 satır 16 satır gibi. Kimi birimde ise 50 satır olabiliyor.
4 - Dosya içerisinde kişisel bilgi yoktur, deneme verileri oluşturulmuştur.
Yardımcı olabilecek arkadaşlara şimdiden teşekkür ederim.
Dosyayı deneyemedim lakin union all ile oluyor heralde sorgu olarak.
Videoyu anlatan adam acayip bişey tavsiye ederim tüm videolarını izlemenizi ingilizce bilmeseniz bile anlıyor insan.Sanırın videodaki gbi istiyorsunuz abey.
Sayın feraz bey web ten benim konu ile ilgili örnek dosyaları inceledim videolara bakmadım. ADO yöntemi kullanılmış.
Dosyalar indirdiğim şekli ile çalışıyorlar benim eklemiş olduğum dosyalara uyarlayamadım. Acaba ne yapabiliriz?
Abey dosyada kod yok ayrıca videoyu izleyip uygulamanızı önermiştim bende uyguladım ufak tefek değişiklik yaparak.
Alttaki kodu deneyin.
Hata olursa koddaki Türkçe karakterleri düzeltin.
Sub test()
Dim rs As Object, con As Object, Sql As String
Set rs = CreateObject("ADODB.Recordset")
Set con = CreateObject("ADODB.Connection")
Dim yol As String, yol2 As String
yol = ThisWorkbook.Path & Application.PathSeparator
yol2 = Dir(yol & "*xlsx")
With ThisWorkbook.Sheets("TümVeri")
.Range("A2:Q" & Rows.Count).Clear
Do Until yol2 = ""
If Not yol2 Like "00 -Tüm Veri*" Then
con.Open "Provider=microsoft.ace.oledb.12.0;data source=" & yol & yol2 & ";extended properties=""Excel 12.0;hdr=yes"""
Sql = Sql & " union all select * from [MEMURLAR$]"
Sql = Mid(sql, 12)
rs.Open sql, con, 1, 1
.Range("A" & Rows.Count).End(3)(2, 1).CopyFromRecordset rs
Sql = ""
rs.Close
con.Close
End If
yol2 = Dir
Loop
End With
Set rs = Nothing
Set con = Nothing
End Sub
Dosyayıda ekleyeyim bari
Eğer verilerin geleceği
Excel Formatı xlsx değilse If Not yol2 Like "00 -Tüm Veri*" Thenve End if kısmını silebilirsiniz.Bende bu dosyada pasif yaptım.
A sütunudaki gereksiz satırları silinki doğru çalışsın alt alta.
Private Sub CommandButton1_Click()
Dim rs As Object, con As Object, Sql As String
Set rs = CreateObject("ADODB.Recordset")
Set con = CreateObject("ADODB.Connection")
Dim yol As String, yol2 As String
yol = ThisWorkbook.Path & Application.PathSeparator
yol2 = Dir(yol & "*xlsx")
With ThisWorkbook.Sheets("TümVeri")
.Range("A2:Q" & Rows.Count).Clear
Do Until yol2 = ""
' If Not yol2 Like "00 -Tüm Veri*" Then
con.Open "Provider=microsoft.ace.oledb.12.0;data source=" & yol & yol2 & ";extended properties=""Excel 12.0;hdr=yes"""
Sql = Sql & " union all select * from [MEMURLAR$]"
Sql = Mid(sql, 12)
rs.Open sql, con, 1, 1
.Range("A" & Rows.Count).End(3)(2, 1).CopyFromRecordset rs
Sql = ""
rs.Close
con.Close
' End If
yol2 = Dir
Loop
End With
Set rs = Nothing
Set con = Nothing
MsgBox "Bitti", vbInformation, "Bilgi"
End Sub