Bir Klasördeki Excel Dosyalarını Birleştiren Makro

[bayhekim81]

Bir klasörde rastgele isimlerden oluşan farklı çalışma kitapları var. Bu çalışma kitaplarındaki tüm satırları ( sıra gözetmeksizin ) tek bir excel sayfasında birleştirilmesini sağlayabilir miyiz?

 

[metin_0606]

Bir klasörde rastgele isimlerden oluşan farklı çalışma kitapları var. Bu çalışma kitaplarındaki tüm satırları ( sıra gözetmeksizin ) tek bir excel sayfasında birleştirilmesini sağlayabilir miyiz?

Bunu Deneyiniz

 

[hamitcan]

Kendim için yaptığım kodu paylaşıyorum.
Microsoft Scripting Runtime referansını eklemeyi unutmayın.

Sub DosyalariBirlestir()
Dim MyFSO As FileSystemObject
Dim MyFile As File
Dim MyFolder As Folder
Yol = ActiveWorkbook.Path
a = activeworkbook.name
Set MyFSO = New Scripting.FileSystemObject
Set MyFolder = MyFSO.GetFolder(Yol)
y = 2
    Workbooks.Add
    ActiveWorkbook.SaveAs "TumHesaplar"

For Each MyFile In MyFolder.Files
    If MyFile.Name Like "*" &  a  & "*" Then GoTo 10
'    If MyFile.Name Like "*~*" Then GoTo 10

    Workbooks.Open Yol & "\" & MyFile.Name
    Set a = Workbooks(MyFile.Name)
    Workbooks(MyFile.Name).Activate
    x = [a65536].End(3).Row - 1
    Workbooks("TumHesaplar").Activate
   
    Range("a" & y & ":ey" & y + x - 2).Value = a.Sheets(1).Range("a2:ey" & x).Value
    a.Close
    ActiveWorkbook.Save
    y = y + x - 1
10
Next
End Sub

 

[bayhekim81]

Microsoft Scripting Runtime referansını ekleme çalıştım umarım olmuştur. Verdiğiniz dosyadaki düğmeye basıp excel dosyalarının olduğu klasörü belirttim. Ama şu hatayı verdi --> Microsoft Scripting Runtime referansını eklemeyi

 

[hamitcan]

Tüm dosyalar aktif dosyanın bulunduğu klasör içinde yer almalı. Browser üzerinden dosya seçimi şeklinde bir kod yapısı mevcut değil. Ama forumda bu şekilde yapılmış kodlar bulabilirsiniz.

 

[usubaykan]

Alternatif olarak bu kodu deneyin.

Option Explicit
Public Sayfa_Adi, Baglanti, Kayit_Seti, Excel, Dosya, S2, Son, Son1
Public Dosyalar, Klasör, Katalog, Data, Tablo, Say, Başla, Bit, Kayit_Zamani

Sub Dış_Veri_Al()
Application.ScreenUpdating = False
Dosya = ThisWorkbook.Path & "\"
Set Dosyalar = CreateObject("Scripting.filesystemobject")
Set Klasör = Dosyalar.GetFolder("" & Dosya & "")

Set S2 = Sheets("Sayfa1")
S2.Cells.Clear

Başla = Time

    For Each Dosyalar In Klasör.Files


    Excel = Dosya & Dosyalar.Name
    S2.Range("G1") = Dosyalar.Name
    
    Say = WorksheetFunction.CountIf(S2.Range("G1"), "*~$*")
    S2.Range("G1").Clear

        If Say = 0 Then
            Set Data = CreateObject("ADODB.Connection")
            Set Katalog = CreateObject("ADOX.Catalog")
            Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Excel & ";"
            Katalog.ActiveConnection = Data
                For Each Tablo In Katalog.Tables
                If InStr(1, Tablo.Type, "TABLE") > 0 Then
                    Son1 = Replace(Tablo.Name, "'", "")
                    If Right(Son1, 1) <> "_" Then
                    If Right(Son1, 1) = "$" Then
                    Sayfa_Adi = Left$(Son1, Len(Son1) - 1)
                End If
        End If


Set Data = Nothing
Set Katalog = Nothing

    
    Dosya = ThisWorkbook.Path & "\"
    
    If Dosyalar.Name <> ThisWorkbook.Name Then
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
   
   Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Excel & _
    ";Extended Properties=""Excel 12.0;Hdr=no;imex=1"";"
    Kayit_Seti.Open "Select * From [" & Sayfa_Adi & "$]", Baglanti, 1, 1
    Son = S2.Cells(S2.Rows.Count, "B").End(3).Row + 1
    Son1 = S2.Cells(S2.Rows.Count, "A").End(3).Row
    If Kayit_Seti(0) > 0 Then
    With S2
        .Cells(.Rows.Count, 1).End(3)(Son + 1 - Son1, 2).CopyFromRecordset Kayit_Seti
        Son1 = .Cells(.Rows.Count, "B").End(3).Row
        .Range("A" & Son & ":A" & Son1) = Dosyalar.Name & " (" & Sayfa_Adi & ")"
    End With
    End If
   
    Kayit_Seti.Close
    Baglanti.Close
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    End If
    End If
    Next
End If

Next
Bit = Time
Kayit_Zamani = (Bit - Başla)
MsgBox "Aktarım yapıldı süre" & vbCrLf & Format(Kayit_Zamani, "HH:MM:SS") & " saniyedir.!"
End Sub