نقل جميع الشيتات الى شيت واحد فقط

[مصطفى الفارس]

السلام عليكم

تحية طيبة 

اخوتي لدي تقريبا 400 شيت واريد ان اجمعهم في شيت واحد فقط 

كيف يتم ذلك ؟

[Ali Mohamed Ali]

وعليكم السلام

أخى الكريم لما لا تقوم بإستخدام خاصية  البحث بالمنتدى طالما لم تقم برفع ملف بالمطلوب ؟ تفضل

مُجمِع البيانات للاكسيل - Excel Data Collector الإصدار الخامس

دمج وتجميع عدة ملفات خارجية فى ملف واحد بالمعادلات

وهذا رابط اخر

دمج ملفات اكسل في ملف واحد

وهذا كود اخر لهذا الموضوع

Sub MergeExcelFiles()
'https://www.ablebits.com/office-addins-blog/2017/11/08/merge-multiple-excel-files-into-one/
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
 
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
 
            Set wbkCurBook = ActiveWorkbook
 
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
 
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
 
                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next
 
                wbkSrcBook.Close SaveChanges:=False
 
            Next
 
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
 
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

وهذا كود ثانى للمطلوب

Sub ConslidateWorkbooks()
'https://trumpexcel.com/combine-multiple-workbooks-one-excel-workbooks/
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "DesktopTest"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
 Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
 For Each Sheet In ActiveWorkbook.Sheets
 Sheet.Copy After:=ThisWorkbook.Sheets(1)
 Next Sheet
 Workbooks(Filename).Close
 Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

 

[أحمد يوسف]

أستاذ مصطفى الفارس

لماذا لا أرى اى ضغط على الإعجاب لكل هذه الإجابات ؟!!!💙