Farklı .xlsx uzantılı dosyalardaki verileri tek dosyada birleştirmek.

[kommissaryuri]

Merhaba, iyi forumlar. Başlıkta da belirttiğim üzere, bir çok farklı .xlsx uzantılı Excel çalışma dosyalarındaki verileri tek bir çalışma sayfasında alt alta getirmek istiyorum. Veriler tek bir sayfada toplanıp alt alta gelse benim için yeterli, sonrasında rötuş yapabilirim fakat temel işlemi gerçekleştirecek makroyu vs. beceremedim. Pratik yolunu bilen, Excel'e hakim forum kullanıcılarından değerleri vakitlerini ayırıp yardımcı olmalarını dilerim.

Teyit etme amaçlı görsel paylaşıyorum, klasördeki Excellerin hepsinde veri mevcut, amacım onların içindeki verilerin tek bir sayfada iç içe girmeden alt alta toplanmalarını sağlamak.
https://hizliresim.com/7Kurgk

 

[tacettinsal]

deneyiniz.

Sub merge()
Dim f As String
Dim fl As String
Dim wb As Workbook

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Birleştirilecek dosyaların olduğu klasörü seçin"
.ButtonName = "Dosya Seç"

    If .Show = 0 Then
    Exit Sub
    Else
    f = .SelectedItems(1) & "\"
    End If
    
fl = Dir(f & "*.xlsx")
Application.ScreenUpdating = False
    Do Until fl = ""
    Set wb = Workbooks.Open(f & fl)
    sat = ThisWorkbook.Sheets(1).Cells(Rows.Count, "A").End(3).Row + 1
    sut = ThisWorkbook.Sheets(1).Cells(1, Columns.Count).End(1).Column
    sat1 = wb.Sheets(1).Cells(Rows.Count, "A").End(3).Row
    sut2 = wb.Sheets(1).Cells(1, Columns.Count).End(1).Column
    
    wb.Sheets(1).Range("a2").resize(sat1, sut2).Copy
    
    Paste ThisWorkbook.Sheets(1).Range(Cells(sat, 1), Cells(sat, sut))
    wb.Close
    fl = Dir
    Loop
End With
Application.ScreenUpdating = True

End Sub

 

[kommissaryuri]

Merhaba, Compile Error aldım. Sub or Function not defined diyor.

caOZy4.png

caOZy4 Fotoğrafı, resimleri, fotoğrafları

hizliresim.com

 

[tacettinsal]

Kodları sayfa1 e kopyalayıp denermisiniz. Modüle kopyalamayın.

 

[kommissaryuri]

Kastettiğiniz bu mudur? https://hizliresim.com/c9kpWQ Sanırım değil ama, acemiliğimi mazur görün.

 

[tacettinsal]

Hayır. Şu şekilde anlatayım. Siz kodları module içerisine kopyalamışsınız. Kod arayüzünde modül kısmının üstünde yazan sayfa1 e çift tıklayıp sayfa1 içerisine kopyalayınız.

 

[stier_22]

hocam bende de buna benzer bir soru var sizin dediğiniz formülü yaptım benim dosyam xls idi kod içinde xlsx silip xls yaptım dosya seçte görünmüyor. Sonra dosyamı xlsx'e dönüştürdüm dosya seç dediğimde gene görünmüyor. Bende ekteki formatta olan 33 dosyayı birleştirmek istiyorum

 

[tacettinsal]

hocam bende de buna benzer bir soru var sizin dediğiniz formülü yaptım benim dosyam xls idi kod içinde xlsx silip xls yaptım dosya seçte görünmüyor. Sonra dosyamı xlsx'e dönüştürdüm dosya seç dediğimde gene görünmüyor. Bende ekteki formatta olan 33 dosyayı birleştirmek istiyorum

Dosya seç kısmında herhangi bir dosya seçimi yapmıyorsunuz.görünmemesi normal. Sadece birleştirilecek xlsx uzantılı dosyaların bulunduğu klasör konumunu seçiyorsunuz. Yazdığım kod o klasör konumundaki xlsx uzantılı bütün dosyaları seçip 1. Sayfasındaki verileri kodu çalıştırdığınız Excel sayfasına alt alta kopyalar.

 

[tacettinsal]

hocam bende de buna benzer bir soru var sizin dediğiniz formülü yaptım benim dosyam xls idi kod içinde xlsx silip xls yaptım dosya seçte görünmüyor. Sonra dosyamı xlsx'e dönüştürdüm dosya seç dediğimde gene görünmüyor. Bende ekteki formatta olan 33 dosyayı birleştirmek istiyorum

sizin örneğiniz kodlar şu şekilde olmalıdır. Deneyiniz.

Sub merge()
Dim f As String
Dim fl As String
Dim wb As Workbook

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Birleştirilecek dosyaların olduğu klasörü seçin"
.ButtonName = "Dosya Seç"

    If .Show = 0 Then
    Exit Sub
    Else
    f = .SelectedItems(1) & "\"
    End If
   
fl = Dir(f & "*.xlsx")
Application.ScreenUpdating = False
    Do Until fl = ""
    Set wb = Workbooks.Open(f & fl)
    sat = ThisWorkbook.Sheets(1).Cells(Rows.Count, "A").End(3).Row + 1
    sut = ThisWorkbook.Sheets(1).Cells(2, Columns.Count).End(1).Column
    sat1 = wb.Sheets(1).Cells(Rows.Count, "A").End(3).Row
    sut2 = wb.Sheets(1).Cells(3, Columns.Count).End(1).Column
   
    wb.Sheets(1).Range("a4").resize(sat1 - 3, sut2).Copy
   
    Paste ThisWorkbook.Sheets(1).Range(Cells(sat, 1), Cells(sat, sut))
    wb.Close
    fl = Dir
    Loop
End With
Application.ScreenUpdating = True

End Sub

 

[stier_22]

sizin örneğiniz kodlar şu şekilde olmalıdır. Deneyiniz.

Sub merge()
Dim f As String
Dim fl As String
Dim wb As Workbook

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Birleştirilecek dosyaların olduğu klasörü seçin"
.ButtonName = "Dosya Seç"

    If .Show = 0 Then
    Exit Sub
    Else
    f = .SelectedItems(1) & "\"
    End If
  
fl = Dir(f & "*.xlsx")
Application.ScreenUpdating = False
    Do Until fl = ""
    Set wb = Workbooks.Open(f & fl)
    sat = ThisWorkbook.Sheets(1).Cells(Rows.Count, "A").End(3).Row + 1
    sut = ThisWorkbook.Sheets(1).Cells(2, Columns.Count).End(1).Column
    sat1 = wb.Sheets(1).Cells(Rows.Count, "A").End(3).Row
    sut2 = wb.Sheets(1).Cells(3, Columns.Count).End(1).Column
  
    wb.Sheets(1).Range("a4").resize(sat1 - 3, sut2).Copy
  
    Paste ThisWorkbook.Sheets(1).Range(Cells(sat, 1), Cells(sat, sut))
    wb.Close
    fl = Dir
    Loop
End With
Application.ScreenUpdating = True

End Sub

Üstat bu şekilde sadece xlsx dosyamı aldı kodun içine girip xlsx silip xls yaptım ama gene xlsx aldı. Dosya sayım 30 un üzeri olduğu için convert yapamıyorum ücretli üyelik istiyor rica etsem bunu xls olarak formülü revize edebilir miisiniz ya da neresini değiştreyim . Ben şu kısımdaki fl = Dir(f & "*.xlsx") xlsx silip xls yaptım

 

[kommissaryuri]

Hayır. Şu şekilde anlatayım. Siz kodları module içerisine kopyalamışsınız. Kod arayüzünde modül kısmının üstünde yazan sayfa1 e çift tıklayıp sayfa1 içerisine kopyalayınız.

Denedim fakat her iki şekilde de kaydetmeme rağmen (makro içeren ya da içermeyen dosya) işlemi yaptığım boş Excel'de ya da farklı kaydettiğimde herhangi bir değişiklik olmadı. Boş excel olarak karşıma çıktılar.