بعد اذن الأستاذ / طارق
تم اضافة الجزء الخاص بمسح بيانات الشيتات المرحل اليها أولا قبل الترحيل لمنع تكرار البيانات
Sub shift_School()
Dim x As Integer
LR = [B10000].End(xlUp).Row
On Error Resume Next
Sheet2.Range("a6:e10000").ClearContents
Sheet3.Range("a6:e10000").ClearContents
Sheet4.Range("a6:e10000").ClearContents
For r = 6 To LR
yy = Cells(r, "C").Value
x = WorksheetFunction.Search("ÈÊÏÇ", yy)
If x = 0 Then GoTo 10
s = Sheet2.[B10000].End(xlUp).Row + 1
Range("A" & r & ":E" & r).Copy (Sheet2.Cells(s, "A"))
x = 0
GoTo 30
10 x = WorksheetFunction.Search("ÚÏÇÏ", yy)
If x = 0 Then GoTo 20
s = Sheet3.[B10000].End(xlUp).Row + 1
Range("A" & r & ":E" & r).Copy (Sheet3.Cells(s, "A"))
x = 0
GoTo 30
20 x = WorksheetFunction.Search("ËÇäæí", yy)
If x = 0 Then GoTo 30
s = Sheet4.[B10000].End(xlUp).Row + 1
Range("A" & r & ":E" & r).Copy (Sheet4.Cells(s, "A"))
x = 0
30 Next r
End Sub
كشف مساعدات2.rar