اخواني الأعزاء بعد سلام الله عليكم ورحمة الله وبركاته
الكود المرفق يقوم بترحيل بيانات التلاميذ والتلميذات الذين لهم دور ثان
محتاج اعدل فيه بحيث بحيث يرحل بيانات التلاميذ والتلميذات الذين لهم دور ثان وكمان ( غ )
Sub Filter_and_copy_with_condition() '********** MOHAMMED HICHAM 02/03/2024****************
Dim d, j
Dim Search As Range, clé As String, IRow As Long
Dim WS As Worksheet: Set WS = Worksheets("cheet4")
Dim F As Worksheet: Set F = Worksheets("شيت الدور الثاني صف رابع ")
d = 9: j = 16: clé = "*" & F.[B1]
IRow = WS.Range("DZ:DZ").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
With Application
.Calculation = xlManual
.ScreenUpdating = False
If Len([B1].Value) = 0 Then: Exit Sub
Set Search = WS.Range("DZ16:DZ" & IRow).Find(clé, LookIn:=xlValues, lookat:=xlWhole)
If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub
F.Range("C10:O" & Rows.Count).ClearContents
Do Until IsEmpty(WS.Range("DZ" & j))
If WS.Range("DZ" & j) Like clé Then
d = d + 1
F.Cells(d, 3).Value = WS.Cells(j, 3).Value
F.Cells(d, 4).Value = WS.Cells(j, 4).Value
F.Cells(d, 5).Value = WS.Cells(j, 5).Value
F.Cells(d, 6).Value = WS.Cells(j, 6).Value
F.Cells(d, 7).Value = WS.Cells(j, 7).Value
F.Cells(d, 8).Value = WS.Cells(j, 8).Value
F.Cells(d, 9).Value = WS.Cells(j, 9).Value
F.Cells(d, 10).Value = WS.Cells(j, 10).Value
F.Cells(d, 11).Value = WS.Cells(j, 11).Value
F.Cells(d, 12).Value = WS.Cells(j, 12).Value
F.Cells(d, 13).Value = WS.Cells(j, 13).Value
F.Cells(d, 14).Value = WS.Cells(j, 14).Value
F.Cells(d, 15).Value = WS.Cells(j, 130).Value
F.Cells(d, 18).Value = WS.Cells(j, 28).Value
F.Cells(d, 21).Value = WS.Cells(j, 40).Value
F.Cells(d, 24).Value = WS.Cells(j, 52).Value
F.Cells(d, 27).Value = WS.Cells(j, 64).Value
F.Cells(d, 30).Value = WS.Cells(j, 76).Value
F.Cells(d, 33).Value = WS.Cells(j, 88).Value
F.Cells(d, 36).Value = WS.Cells(j, 100).Value
F.Cells(d, 39).Value = WS.Cells(j, 112).Value
F.Cells(d, 42).Value = WS.Cells(j, 116).Value
End If
j = j + 1
Loop
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub