اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

احتاج كود ت رحيل من اساتذتي


degabro

الردود الموصى بها

أرجو من اساتذتي بالمنتدي حل هذه المشكلة الخاصة بي

احتاج الي عمل كود ترحيل علي شيت aa وشيت bb بحيث انه عند كتابة بيانات في شيت aa وهو الخاص بالمحولين الي المدرسة يتم اضافة البيان الجديد الي مكانة الصحيح في الشيت الخاص به اي عندما تكون البيانات لطالب في الصف الخامس يتم ترحيل بياناته الي الشيت الخاص بالصف الخامس وهو 5 وهكذا

وعندما اكتب بيانات في شيت bb وهو الخاص بالمحولين من المدرسة يتم حذف هذا الاسم من الشيت الخاص به

مع مراعاة عدم تأثر اي معادلات موجودة بالشيت المرحل اليه

ارجو الافادة اساتذتي

Book1.zip

رابط هذا التعليق
شارك

السلام عليكم

أخي العزيز

هذا الكود للمحولين إلي المدرسة


Sub ToSchool()

'

' Macro1 Macro

'


Lst_R = [B1000].End(xlUp).Row

For r = 12 To Lst_R

	cls = Cells(r, 3)

	For w = 1 To Worksheets.Count

    	a = Format(cls, "0")

    	If Sheets(w).Name = a Then

        	Range("B" & r & ":R" & r).Copy

        	new_R = Sheets(a).[B1000].End(xlUp).Row + 1

        	Sheets(a).Range("B" & new_R).PasteSpecial Paste:=xlPasteValues

        	Sheets(a).Range("A" & new_R).Value = Sheets(a).Range("A" & new_R - 1).Value + 1

        	Range("A" & r & ":R" & r).ClearContents

        	Application.CutCopyMode = False

        	GoTo 10

    	End If

 	Next w

' No sheets named this Class

	MsgBox ("No Class =" & cls)

	Exit Sub


10      	' exit FOR w



Next r



End Sub

وهذا للمحولين من المدرسة
Sub FromSchool()

'

' Macro1 Macro

'


Lst_R = [B1000].End(xlUp).Row

For r = 12 To Lst_R

	cls = Cells(r, 3)

	kid = Cells(r, 2)

	For w = 1 To Worksheets.Count

    	a = Format(cls, "0")

    	If Sheets(w).Name = a Then

       	' Range("B" & r & ":R" & r).Copy

        	new_R = Sheets(a).[B1000].End(xlUp).Row

            	For i = 11 To new_R

                	kkid = Sheets(a).Cells(i, 2)

                	If kkid = kid Then GoTo 15

            	Next i

            	' Not found the KID's name in this Class

            	MsgBox ("No KID's named " & Chr(10) & kid & Chr(10) & "in Class " & a)

            	Exit Sub


15      	' found the KID - exit FOR i (keep the Row number of Kid in i)

        	Sheets(a).Range("B" & i + 1 & ":R" & new_R + 1).Copy

        	Sheets(a).Range("B" & i).PasteSpecial Paste:=xlPasteValues

        	Sheets(a).Range("A" & new_R).ClearContents

        	Range("A" & r & ":R" & r).ClearContents

        	GoTo 10

    	End If

 	Next w

' No sheets named this Class

	MsgBox ("No Class =" & a)

	Exit Sub


10      	' exit FOR w

        	Application.CutCopyMode = False


Next r



End Sub

وتفضل المرفق أيضا

المحولين.rar

رابط هذا التعليق
شارك

فقط للتذكير

ارب ماتكونوش نمتوا

قواعد المشاركة فى الموقع

اضغط هنـــــــــامن فضلك لقراء القواعد كاملة

و بصفة خاصة نؤكدعلى ما يلي

1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة

2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد.

3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال.

4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا.....

5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم.

ومخالفة ذلك تعرض الموضوع للحذف

رابط هذا التعليق
شارك

اخي العزيز TareQ M

أأسف بشدة علي جملتي التي قلتها في التعليق السابق

ولكن هذا من قبيل العشم كما يقولون

ونظرا لأني كنت في امس الحاجة لهذا الموضوع

ولا انكر افضال هذا المنتدي علي وكذلك اعضاءه

واكرر اسفي اخي العزيز

رابط هذا التعليق
شارك

السلام عليكم

أخي ديجابرو

إستبدل الكود بالتالي

سنقسم عملية النسخ واللصق ثلاث مقاطع لتلافي الخلايا التي بها معادلات


Sub ToSchool()

'

' Macro1 Macro

'


Lst_R = [B1000].End(xlUp).Row

For r = 12 To Lst_R

	cls = Cells(r, 3)

	For w = 1 To Worksheets.Count

    	a = Format(cls, "0")

    	If Sheets(w).Name = a Then

        	Range("B" & r & ":I" & r).Copy

        	new_R = Sheets(a).[B1000].End(xlUp).Row + 1

        	Sheets(a).Range("B" & new_R).PasteSpecial Paste:=xlPasteValues

        	Range("M" & r & ":N" & r).Copy

        	Sheets(a).Range("M" & new_R).PasteSpecial Paste:=xlPasteValues

        	Range("P" & r & ":R" & r).Copy

        	Sheets(a).Range("P" & new_R).PasteSpecial Paste:=xlPasteValues


        	Sheets(a).Range("A" & new_R).Value = Sheets(a).Range("A" & new_R - 1).Value + 1

        	Range("A" & r & ":I" & r).ClearContents

        	Range("M" & r & ":N" & r).ClearContents

        	Range("P" & r & ":R" & r).ClearContents

        	Application.CutCopyMode = False

        	GoTo 10

    	End If

 	Next w

' No sheets named this Class

	MsgBox ("No Class =" & cls)

	Exit Sub


10      	' exit FOR w



Next r



End Sub


Sub FromSchool()

'

' Macro1 Macro

'


Lst_R = [B1000].End(xlUp).Row

For r = 12 To Lst_R

	cls = Cells(r, 3)

	kid = Cells(r, 2)

	For w = 1 To Worksheets.Count

    	a = Format(cls, "0")

    	If Sheets(w).Name = a Then

       	' Range("B" & r & ":R" & r).Copy

        	new_R = Sheets(a).[B1000].End(xlUp).Row

            	For i = 11 To new_R

                	kkid = Sheets(a).Cells(i, 2)

                	If kkid = kid Then GoTo 15

            	Next i

            	' Not found the KID's name in this Class

            	MsgBox ("No KID's named " & Chr(10) & kid & Chr(10) & "in Class " & a)

            	Exit Sub


15      	' found the KID - exit FOR i (keep the Row number of Kid in i)

        	Sheets(a).Range("B" & i + 1 & ":I" & new_R + 1).Copy

        	Sheets(a).Range("B" & i).PasteSpecial Paste:=xlPasteValues


        	Sheets(a).Range("M" & i + 1 & ":N" & new_R + 1).Copy

        	Sheets(a).Range("M" & i).PasteSpecial Paste:=xlPasteValues


        	Sheets(a).Range("P" & i + 1 & ":R" & new_R + 1).Copy

        	Sheets(a).Range("P" & i).PasteSpecial Paste:=xlPasteValues


        	Sheets(a).Range("A" & new_R).ClearContents

       	Range("A" & r & ":I" & r).ClearContents

        	Range("M" & r & ":N" & r).ClearContents

        	Range("P" & r & ":R" & r).ClearContents

        	GoTo 10

    	End If

 	Next w

' No sheets named this Class

	MsgBox ("No Class =" & a)

	Exit Sub


10      	' exit FOR w

        	Application.CutCopyMode = False


Next r



End Sub

رابط هذا التعليق
شارك

الاخ / الاستاذ طارق :

على مايبدو نحن محكومين بأن نقول دائما لحضرتك شكرا.... شكرا

والله روعة

وفقك الله

ياسر الحافظ

الأخ العزيز علي الروح القريب من القلب / ياسر الحافظ

اللهم أعز سوريا وأهلها

وسائر بلاد المسلمين

أخي الكريم ،

شاكرا جدا مرورك وكلماتك الرقيقة

تقبل ودي واحترامي

أخوكم طارق محمود (أبو زياد)

تم تعديل بواسطه TareQ M
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information