klasördeki bütün excel dosyaları alt alta birleştirme

[orkunozbudak]

herkese merhaba klasördeki bütün excel dosyalarını birleştirmek istiyorum birkaç tane makro denedım fakat excel içindeki bazı bilgileri alıyor bazılarını almıyor hatasız eksiksiz alıcak bir makroya ihtiyacım var dosyaları eklıyorum sımdıden tesekkurler

 

[RBozkurt]

Deneyiniz,

Sub AltAltaBirlestir()
    Dim FolderPath As String
    Dim FileName As String
    Dim WbSource As Workbook
    Dim WsSource As Worksheet
    Dim WsDest As Worksheet
    Dim LastRow As Long
    Dim DestRow As Long

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Bir klasör seçin"
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        FolderPath = .SelectedItems(1) & "\"
    End With

    Set WsDest = ThisWorkbook.Sheets.Add
    WsDest.Name = "Birleştirilenler"
    DestRow = 1

    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        Set WbSource = Workbooks.Open(FolderPath & FileName)
        Set WsSource = WbSource.Sheets(1)
        
        LastRow = WsSource.Cells(WsSource.Rows.Count, "A").End(xlUp).Row
        WsSource.Range("A1:A" & LastRow).EntireRow.Copy Destination:=WsDest.Range("A" & DestRow)
        
        DestRow = WsDest.Cells(WsDest.Rows.Count, "A").End(xlUp).Row + 1
        
        WbSource.Close SaveChanges:=False
        FileName = Dir
    Loop

    MsgBox "Tüm dosyalar başarıyla birleştirildi!", vbInformation
End Sub

 

[orkunozbudak]

Deneyiniz,

Sub AltAltaBirlestir()
    Dim FolderPath As String
    Dim FileName As String
    Dim WbSource As Workbook
    Dim WsSource As Worksheet
    Dim WsDest As Worksheet
    Dim LastRow As Long
    Dim DestRow As Long

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Bir klasör seçin"
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        FolderPath = .SelectedItems(1) & "\"
    End With

    Set WsDest = ThisWorkbook.Sheets.Add
    WsDest.Name = "Birleştirilenler"
    DestRow = 1

    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        Set WbSource = Workbooks.Open(FolderPath & FileName)
        Set WsSource = WbSource.Sheets(1)
       
        LastRow = WsSource.Cells(WsSource.Rows.Count, "A").End(xlUp).Row
        WsSource.Range("A1:A" & LastRow).EntireRow.Copy Destination:=WsDest.Range("A" & DestRow)
       
        DestRow = WsDest.Cells(WsDest.Rows.Count, "A").End(xlUp).Row + 1
       
        WbSource.Close SaveChanges:=False
        FileName = Dir
    Loop

    MsgBox "Tüm dosyalar başarıyla birleştirildi!", vbInformation
End Sub

Merhaba teşekkür ediyorum fakat excel dosyaların içinde bazılarında 2 sayfa var ve isimleri data , komax bu komaxtaki bazı veriler sizin makrodada almamış örnek veriyorum 0535 varyantındaki bu kabloları eklememiş

0522.1-1	0,5		BU	1740	X3707/X1	21A07/X1	A 619 540 05 35	A 619 540 20 13	A0005469001	KOMAX	16.11.2021	001
0522.1-4	0,5		YE	1740	X3707/X1	21A07/X1	A 619 540 05 35	A 619 540 20 13	A0005469001	KOMAX	16.11.2021	001
0522.1-2	0,5		BK	1740	X3707/X1	21A07/X1	A 619 540 05 35	A 619 540 20 13	A0005469001	KOMAX	16.11.2021	001
0522.1-3	0,5		BN	1740	X3707/X1	21A07/X1	A 619 540 05 35	A 619 540 20 13	A0005469001	KOMAX	16.11.2021	001