EXCEL' DE ÇALIŞMA SAYFALARINI BİRLEŞTİRME

Excel' de birden fazla çalışma sayfalarını birleştirmek için Makro yazarak işimizi kolaylaştırabiiriz.

Yapmamız gereken;
Ana Excel Dosyamız oluşturmak, sonra aşağıda ki kodu vba alanına yazmanız.

Sub Dosya_Veri()

Dim vaFiles As Variant
Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Sayın " & Environ("UserName")

ms1 = MsgBox("Birden Fazla Dosyadan Veri Almak mı İstiyorsunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
    ws.Range("A2:g" & Rows.Count).Clear
    
    lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
    Title:="Select Files to Proceed", MultiSelect:=True)
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If
            
            Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
            
            Set wsa = ActiveWorkbook.ActiveSheet
            
            lra = wsa.Cells(Rows.Count, 1).End(xlUp).Row
            lrc = wsa.Cells(1, Columns.Count).End(xlToLeft).Column
            
            For c = 1 To lc
                For ca = 1 To lrc
                    If wsa.Cells(1, ca) = ws.Cells(1, c) Then
                        cn = ca
                        Exit For
                    End If
                Next ca
                For r = 2 To lra
                    y = ws.Cells(Rows.Count, c).End(xlUp).Offset(1, 0).Row
                    If c <> lc Then
                        ws.Cells(y, c) = wsa.Cells(r, cn)
                    Else
                        ws.Cells(y, c) = "FileName: " & Mid(ActiveWorkbook.Name, 1, InStr(1, _
                        ActiveWorkbook.Name, ".xls") - 1)
                    End If
                    y = y + 1
                Next r
            Next c
            wbkToCopy.Close savechanges:=False
skipfile:
        Next i
        ws.Range("A1:g1").EntireColumn.AutoFit
        ms5 = MsgBox("Verileriniz  başarılı bir şekilde aktarılmıştır", vbInformation, un)
    Else
        ms3 = MsgBox("Dosya Seçiniz!", vbExclamation, un)
    End If
Else
    ms2 = MsgBox("İşlemi İptal Ettiniz", vbInformation, un)
End If

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub