حذف صفوف إعتمادا على شرط

'الكود للأستاذ الفاضل ياسر خليل أبو البراء

' وتمت الإضافات بمعرفة الأستاذ الفاضل حسونه

'بارك الله فيكم جميعا

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