Klasör içerisindeki excel dosyalarını tek dosyada birleştirme

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
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.
 

Ekli dosyalar

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Aşağıdaki kodu TümVeri sayfanızda çalıştırabilisiniz.
Not: Forumda arattım ve buldum, küçük bir döngü ilavesi yaptım.

Kod:
Sub Test2()
'   Haluk - 03/03/2020
'   sa4truss@gmail.com

    Dim adoCN As Object, RS As Object
    Dim myFile As String, strSQL As String
    Dim strLastData As String
    
    mySelect = "[SİCİL],[Rütbesi],[KODU], [Adı SOYADI], [TELEFON], [BİRİM], [CİNSİYET], [DİĞER], [PAZARTESİ], [SALI],[ÇARŞAMBA], [PERŞEMBE], [CUMA], [CUMARTESİ], [PAZAR], [AÇIKLAMA]"
    Const adOpenKeyset = 1
For i = 1 To 50
    myFile = ThisWorkbook.Path & Application.PathSeparator & "BİRİM (" & i & ").xlsx"
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
 
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = myFile
    adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=yes; IMEX=1"
    adoCN.Open
 
    strSQL = "Select " & mySelect & " from [MEMURLAR$] where [SİCİL] is not null"
    
    RS.CursorType = adOpenKeyset
    RS.Open strSQL, adoCN
    SonSat = Range("B" & Rows.Count).End(xlUp).Row + 1
    If RS.RecordCount > 0 Then
       Sheets("TümVeri").Range("B" & SonSat).CopyFromRecordset RS
    End If
    RS.Close
    adoCN.Close
Next i
    Set RS = Nothing
    Set adoCN = Nothing
    
    Range("A2") = 1
    Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row).Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
    Range("A2").Select
End Sub
 

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
@NextLevel ;

Nezaketiniz için teşekkürler....

.
 

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
Sayın @NextLevel macroyu bir modül ekleyip uyguladım ama hata alıyorum. Acaba neyi yanlış yaptım.
 

Ekli dosyalar

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Veri alacağınız Birim (1)..(50) çalışma kitaplarının hepsinin
kodlarınızın olduğu kitapla aynı klasörde ve kapalı olması şart.
 

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
917
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
Teşekkürler. Emeğinize sağlık.
 
Üst