السلام عليكم
اكيد حل الاستاذ طارق محمود
مابعده كلام
ولاكن قد عملت على الملف
ارفق الكود
مدى النسخ واحد
Public Sub Ali_Rn()
Dim W As Workbook
Dim Sh As Worksheet
Dim Path$, My_F$
Dim Rng As Range
Nm = ThisWorkbook.Name
Path = ThisWorkbook.Path & Application.PathSeparator
My_F = Dir(Path & "*.xlsx")
On Error Resume Next
Do While My_F <> ""
If Not My_F = Nm Then
Workbooks.Open Filename:=Path & "\" & My_F
Set W = Workbooks(My_F)
For Each Sh In W.Worksheets
With Sh
SPd False
Set Rng = .Range(.Cells(2, 1), .Cells(500, 15))
Rng.Copy
With Workbooks(Nm).Worksheets(.Name)
Lc = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Range("A" & Lc).PasteSpecial xlPasteValues
End With
End With
Next
W.Close 0
SPd True
End If
My_F = Dir
Loop
End Sub
Private Function SPd(Bn As Boolean)
With Application
.Calculation = IIf(Bn, -4105, -4135)
.EnableEvents = Bn
.ScreenUpdating = Bn
.DisplayAlerts = Bn
End With
End Function