إذا سمحتم حد يترجملي هذا الكود
Dim LR As Integer
LR = [a10000].End(xlUp).Row
Sheets("ÇáäÇÌÍæä").Range("a9:am138").ClearContents
Sheets("ÑÇÓÈ").Range("a8:am1000").ClearContents
Application.ScreenUpdating = False
X = 8: Y = 8
For I = 8 To LR
If Cells(I, 39).Value = "äÇÌÍ" And Cells(I, 2) <> " " Then
Range("a" & I).Resize(1, 39).Copy
Sheets("ÇáäÇÌÍæä").Range("a" & X).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
X = X + 1
ElseIf Cells(I, 39).Value = " áå 쾄 ËÇä" And Cells(I, 2) <> " " Then
Range("a" & I).Resize(1, 39).Copy
Sheets("ÑÇÓÈ").Range("a" & Y).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Y = Y + 1
End If
Next I
Application.ScreenUpdating = True
End Sub