'الكود للأستاذ الفاضل ياسر خليل أبو البراء
' وتمت الإضافات بمعرفة الأستاذ الفاضل حسونه
'بارك الله فيكم جميعا
Sub Test()
Const shName1 As String = "ورقة8", shName2 As String = "ورقة9"
Dim wbResult As Workbook, wb As Workbook, sh1 As Worksheet, sh2 As Worksheet, ws1 As Worksheet, ws2 As Worksheet, myPath As String, myFile As String, sh As Worksheet
Application.ScreenUpdating = False
Set wbResult = Workbooks.Open(ThisWorkbook.Path & "\النتائج.xlsx")
With wbResult
Set sh1 = .Worksheets(shName1)
Set sh2 = .Worksheets(shName2)
sh1.Range("A1").CurrentRegion.Offset(1).Clear
sh2.Range("A1").CurrentRegion.Offset(1).Clear
End With
myPath = ThisWorkbook.Path & "\المجلد الرئيسى\"
myFile = Dir(myPath & "*.xls*")
Do While myFile <> ""
Set wb = Workbooks.Open(myPath & myFile, False)
Set ws1 = wb.Worksheets(shName1)
Set ws2 = wb.Worksheets(shName2)
ws1.Range("A1").CurrentRegion.Offset(1).Copy sh1.Range("A" & sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1)
ws2.Range("A1").CurrentRegion.Offset(1).Copy sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1)
'----------------------------------------------------------------------------------------------
For Each sh In wbResult.Worksheets(Array("ورقة8", "ورقة9"))
With sh
.Range("A1:K" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).AutoFilter Field:=4
With .AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("d2:d" & sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1), SortOn:=xlSortOnValues, Order:=xlAscending
.SortFields.Add Key:=Range("f2:f" & sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1), SortOn:=xlSortOnValues, Order:=xlAscending
.Apply
End With
Application.Goto .Range("A1")
Dim lr As Long
lr = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("a2:a" & lr + 1).NumberFormat = "0"
.Range("b2:f" & lr + 1).NumberFormat = "@"
.Range("h2:h" & lr + 1).NumberFormat = "General"
.Range("i2:i" & lr + 1).NumberFormat = "0000"
.Range("j2:j" & lr + 1).NumberFormat = "General"
.Range("k2:k" & lr + 1).NumberFormat = "0.00"
End With
Next sh
'----------------------------------------------------------------------------------------------
wbResult.Worksheets("ورقة9").Range("g2:g" & lr + 1).NumberFormat = "0000" 'ورقه9
wbResult.Worksheets("ورقة8").Range("g2:g" & lr + 1).NumberFormat = "0.00" 'ورقه8
wb.Close SaveChanges:=False
myFile = Dir
Loop
wbResult.Close SaveChanges:=True
Application.ScreenUpdating = True
MsgBox "Done...", 64
End Sub