نجوم المشاركات

السلام عليكم تفضل أخي هذا الكود بعد التعديل Sub SameCells() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.DisplayAlerts = False On Error Resume Next Dim Fil As String, A(9, 99, 99, 99) As Long, nm(99, 99) As String '============================================================ x = ActiveWorkbook.Name Fil = Dir(ActiveWorkbook.Path & "\" & "*.xls") wb = 0 Do Until Fil = "" If Fil = x Then GoTo 10 wb = wb + 1 Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & Fil CN = Sheets.Count If mxCN < CN Then mxCN = CN For sh = 1 To CN nm(wb, sh) = Sheets(sh).Name For cc = 1 To 8 ' Columns A:H For rr = 1 To 20 ' Rows A(wb, sh, rr, cc) = Sheets(sh).Cells(rr, cc) Next rr Next cc Next sh ActiveWorkbook.Close 10 Fil = Dir Loop For sh = 1 To Sheets.Count Sheets(sh).Range("A1:H20").ClearContents For w = 1 To wb For n = 1 To mxCN If nm(w, n) = Sheets(sh).Name Then For cc = 1 To 8 ' Columns A:H For rr = 1 To 20 ' Rows Sheets(sh).Cells(rr, cc).Value = Sheets(sh).Cells(rr, cc).Value + A(w, n, rr, cc) Next rr Next cc GoTo 15 End If Next n 15 Next w Next sh Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True End Sub وهذا هو المجلد وبه ملفات مختلفة واوراق متشابهة الأسماء للتجربة تفضل المرفق Has100.rar