السلام عليكم
اخي ابوعلام
سيصبح الكود هكذا
Sub Abu_Ahmed()
Dim cl As Range
Range("B8:D52,B56:D100,B104:D148,B152:D196,B200:D244").ClearContents
Set MyRng = Sheets("البيانات").Range("D8:D1000")
Application.ScreenUpdating = False
For Each cl In MyRng
If cl.Value = [B6].Value Then
LR = Cells(52, 2).End(xlUp).Row + 1
Cells(LR, 2) = cl.Offset(0, -1)
Cells(LR, 3) = cl.Offset(0, 1)
Cells(LR, 4) = cl.Offset(0, 2)
End If
' =====
If cl.Value = [B54].Value Then
LR = Cells(100, 2).End(xlUp).Row + 1
Cells(LR, 2) = cl.Offset(0, -1)
Cells(LR, 3) = cl.Offset(0, 1)
Cells(LR, 4) = cl.Offset(0, 2)
End If
' =====
If cl.Value = [B102].Value Then
LR = Cells(148, 2).End(xlUp).Row + 1
Cells(LR, 2) = cl.Offset(0, -1)
Cells(LR, 3) = cl.Offset(0, 1)
Cells(LR, 4) = cl.Offset(0, 2)
End If
' =====
If cl.Value = [B150].Value Then
LR = Cells(196, 2).End(xlUp).Row + 1
Cells(LR, 2) = cl.Offset(0, -1)
Cells(LR, 3) = cl.Offset(0, 1)
Cells(LR, 4) = cl.Offset(0, 2)
End If
' =====
If cl.Value = [B198].Value Then
LR = Cells(244, 2).End(xlUp).Row + 1
Cells(LR, 2) = cl.Offset(0, -1)
Cells(LR, 3) = cl.Offset(0, 1)
Cells(LR, 4) = cl.Offset(0, 2)
End If
'=====
Next
End Sub