(تمت الاجابة) استخراج اسم المرحلة من بين اسماء المدارس

[منياوى]

الملف المرفق على هذا الرابط به اسماء الطلاب الفقراء الذين يتم مساعدتهم من المراحل التعليمية الثلاثة ( ابتدائى - اعدادى - ثانوى )

فى الصفحة الاولى يتم كتابه اسماء جميع الطلاب بجميع المراحل

والمطلوب هو ترحيل اسماء المدارس حسب كل مرحلة الى الصفحه الخاصة بكل مرحلة

علما بان اسم المرحلة قد ياتى فى بداية اسم المدرسة او فى المنتصف او فى النهاية

والمطلوب فى الملف المرفق ولكم جزيل الشكر

http://www.4shared.c...T/__online.html

تم تعديل فبراير 19, 2012 بواسطه jo11

[طارق محمود]

السلام عليكم

تفضل هذا هو الكود

Sub shift_School()

Dim x As Integer


LR = [B10000].End(xlUp).Row

On Error Resume Next


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

[رجب جاويش]

الأستاذ الفاضل / طارق

تسلم ايديك على هذا الكود الجميل

ولكن برجاء اضافة تعديل لمنع تكرار البيانات المرحلة عند الضغط على زر الترحيل أكثر من مره

[رجب جاويش]

بعد اذن الأستاذ / طارق

تم اضافة الجزء الخاص بمسح بيانات الشيتات المرحل اليها أولا قبل الترحيل لمنع تكرار البيانات

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

[منياوى]

جزاكم الله كل خير ولكم منى الف الف شكر

[منياوى]

اشكركم على إهتمامكم بالرد السريع جزاكم الله كل خير واريد ان اثقل عليكم مرة اخرى

احيانا يتم تدوين مثلا عشرين او ثلاثين اسم من مدرسة واحدة

فهل هناك طريقه لمنع تكرار اسماء الطلاب فى أى مدرسة