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

مطلوب تصحيح كود ترحيل


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

الرجاء المساعدة فى تصحيح الكود التالى مع توضيح الخطأ للتعلم

الكود يقوم بترحيل الطالبات من السجل العام للصف إلى فصولهن


Sub ترحيل_فصول()

		  '''  متغيرات بعدد الصفحات المطلوب الترحيل اليها

Dim R As Integer, A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer

		  '''  أسماء الصفحات المطلوب الترحيل اليها والمدى المطلوب مسح البيانات القديمة منه

    Sheets("1").Range("A5:DZ5000").ClearContents

    Sheets("2").Range("A5:DZ5000").ClearContents

    Sheets("3").Range("A5:DZ5000").ClearContents

    Sheets("4").Range("A5:DZ5000").ClearContents

    Sheets("5").Range("A5:DZ5000").ClearContents

    Sheets("6").Range("A5:DZ5000").ClearContents

	    '''  عدد الصفوف العليا في الصفحات المنقول اليها البيانات

    A = 4: B = 4: C = 4: D = 4: E = 4: F = 4

    Application.ScreenUpdating = False

		  '''  بداية ونهاية صفوف الورقة المصدر

    For R = 5 To 5000


   '''''''''''''''''''''''''''''''''''''''''''''''''''

   ''تكرر الأسطر التالية لكل شيت يتم الترحيل فيه مع تغيير المتغيرات

			    ''' رقم عمود المعيار وكلمة المعيار

	    If Cells(R, 4) = "1" Then

			    ''' عدد الأعمدة التى سيتم ترحيلها

		    Range("A" & R).Resize(1, 9).Copy

				  '''  سيتم اللصق في هذا الشيت

		    Sheets("1").Range("A" & A).PasteSpecial xlPasteValues

		    Application.CutCopyMode = False

		    A = A + 1

				 '''''''''''''''''''''''''''''''''''''''''''''''''''''


	    If Cells(R, 4) = "2" Then

		    Range("A" & R).Resize(1, 9).Copy

		    Sheets("2").Range("A" & B).PasteSpecial xlPasteValues

		    Application.CutCopyMode = False

		    B = B + 1

				 '''''''''''''''''''''''''''''''''''''''''''''''''''''


	    If Cells(R, 4) = "3" Then

		    Range("A" & R).Resize(1, 9).Copy

		    Sheets("3").Range("A" & C).PasteSpecial xlPasteValues

		    Application.CutCopyMode = False

		    C = C + 1

				 '''''''''''''''''''''''''''''''''''''''''''''''''''''


	    If Cells(R, 4) = "4" Then

		    Range("A" & R).Resize(1, 9).Copy

		    Sheets("4").Range("A" & D).PasteSpecial xlPasteValues

		    Application.CutCopyMode = False

		    D = D + 1

				 '''''''''''''''''''''''''''''''''''''''''''''''''''''


	    If Cells(R, 4) = "5" Then

		    Range("A" & R).Resize(1, 9).Copy

		    Sheets("5").Range("A" & E).PasteSpecial xlPasteValues

		    Application.CutCopyMode = False

		    E = E + 1

				 '''''''''''''''''''''''''''''''''''''''''''''''''''''


	    If Cells(R, 4) = "6" Then

		    Range("A" & R).Resize(1, 9).Copy

		    Sheets("6").Range("A" & F).PasteSpecial xlPasteValues

		    Application.CutCopyMode = False

		    F = F + 1

				 '''''''''''''''''''''''''''''''''''''''''''''''''''''


	 '   If Cells(R, 4) = "1" Then

	 '	   Range("A" & R).Resize(1, 9).Copy

	 '	   Sheets("1").Range("A" & A).PasteSpecial xlPasteValues

	 '	  Application.CutCopyMode = False

	 '	  A = A + 1


    ''''''''''''''''''''''''''''''''''''''''''''''''''''


	    End If


   '''''''''''''''''''''''''''''''''''''''''''''''''''''


    Next


    MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى فصلها ")

    Application.ScreenUpdating = True

End Sub

   '''''''''''''''''''''''''''''''''''''''''''''''''''''

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

السلام عليكم ورحمة الله

تقبل الله منا ومنكم الصلاة والصيام والقيام وصالح الأعمال وجمعة مباركة لكل المسلمين....

أخي الكريم يوسف، لتصحيح الكود وعمله يكفي إضافة العبارة End If لكل If في الكود فيكون الكود في الأخير كما يلي:

Sub ترحيل_فصول()

''' متغيرات بعدد الصفحات المطلوب الترحيل اليها

Dim R As Integer, A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer

''' أسماء الصفحات المطلوب الترحيل اليها والمدى المطلوب مسح البيانات القديمة منه

Sheets("1").Range("A5:DZ5000").ClearContents

Sheets("2").Range("A5:DZ5000").ClearContents

Sheets("3").Range("A5:DZ5000").ClearContents

Sheets("4").Range("A5:DZ5000").ClearContents

Sheets("5").Range("A5:DZ5000").ClearContents

Sheets("6").Range("A5:DZ5000").ClearContents

''' عدد الصفوف العليا في الصفحات المنقول اليها البيانات

A = 4: B = 4: C = 4: D = 4: E = 4: F = 4

Application.ScreenUpdating = False

''' بداية ونهاية صفوف الورقة المصدر

For R = 5 To 5000


'''''''''''''''''''''''''''''''''''''''''''''''''''

''تكرر الأسطر التالية لكل شيت يتم الترحيل فيه مع تغيير المتغيرات

''' رقم عمود المعيار وكلمة المعيار

If Cells(R, 4) = "1" Then

''' عدد الأعمدة التى سيتم ترحيلها

Range("A" & R).Resize(1, 9).Copy

''' سيتم اللصق في هذا الشيت

Sheets("1").Range("A" & A).PasteSpecial xlPasteValues

Application.CutCopyMode = False

A = A + 1

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''


If Cells(R, 4) = "2" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("2").Range("A" & B).PasteSpecial xlPasteValues

Application.CutCopyMode = False

B = B + 1

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''


If Cells(R, 4) = "3" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("3").Range("A" & C).PasteSpecial xlPasteValues

Application.CutCopyMode = False

C = C + 1

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''


If Cells(R, 4) = "4" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("4").Range("A" & D).PasteSpecial xlPasteValues

Application.CutCopyMode = False

D = D + 1

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''

If Cells(R, 4) = "5" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("5").Range("A" & E).PasteSpecial xlPasteValues

Application.CutCopyMode = False

E = E + 1

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''

If Cells(R, 4) = "6" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("6").Range("A" & F).PasteSpecial xlPasteValues

Application.CutCopyMode = False

F = F + 1

End If


'''''''''''''''''''''''''''''''''''''''''''''''''''''


Next


MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى فصلها ")

Application.ScreenUpdating = True

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''

والله أعلم

أخوك بن علية

تم تعديل بواسطه بن علية حاجي
رابط هذا التعليق
شارك

الله ينور عليك يا استاذنا الغالى

صحيح حرف واحد ناقص فى الكود يخلى الواحد يلف حوالين نفسه

لو تكرمت كان فى طريقة بتقوم بعد الترحيل بإخراج إحصائية بعدد البيانات المرحلة فى كل شيت وعمل تسلسل تلقائى فى كل شيت

هل ممكن المساعدة فى عمل هذه الإحصائية والتسلسل التلقائى هنا فى هذا الكود ؟؟

علما بأن التسلسل التلقائى سيكون فى العمود B بدءاً من الخلية B5 إلى آخر سطر يكون فيه بيانات مرحلة

ومرفق جزء من كود قديم يحتوى على إحصائية مشابهة وتسلسل مشابه


Next a

Application.CutCopyMode = False

Application.ScreenUpdating = True

MsgBox "!تم الترحيل   بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل"

' وهنا تطوير طفيف ليلائم العدد المتغير للحالات

For i = 1 To case_NO

			    x(i) = Sheets(sht(i)).[A3000].End(xlUp).Row - 10

			    mssg = mssg & Chr(10) & x(i) & " " & sht(i)

Next i

MsgBox (" تم ترحيل عدد" & mssg)

Range("a1").Select

' وأخيرا هذا الجزء لضبط المسلسل في الشيتات التي حدث الترحيل إليها

For i = 1 To case_NO

			    Sheets(sht(i)).[A11] = 1

			    rrw = Sheets(sht(i)).[A3000].End(xlUp).Row

			    For Each cc In Sheets(sht(i)).Range("A12:A" & rrw)

											    cc.Value = cc.Offset(-1, 0) + 1

			    Next cc

Next i

On Error Resume Next

On Error GoTo 0

End Sub

الف شكر للغاليين وكل عام وأنتم بخير

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

السلام عليكم ورحمة الله

تقبل الله منا ومنكم صالح الأعمال بمزيد من الأجر والثواب...

أخي الكريم هذه محاولة في الكود ولكن جعلت الترقيم التلقائي للتسلسل في العمود A انطلاقا من الخلية A5 ويمكنك التغيير فيه.....


Sub ترحيل_فصول()

''' متغيرات بعدد الصفحات المطلوب الترحيل اليها


Dim R As Integer, A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer

''' أسماء الصفحات المطلوب الترحيل اليها والمدى المطلوب مسح البيانات القديمة منه

Sheets("1").Range("A5:DZ5000").ClearContents

Sheets("2").Range("A5:DZ5000").ClearContents

Sheets("3").Range("A5:DZ5000").ClearContents

Sheets("4").Range("A5:DZ5000").ClearContents

Sheets("5").Range("A5:DZ5000").ClearContents

Sheets("6").Range("A5:DZ5000").ClearContents

''' عدد الصفوف العليا في الصفحات المنقول اليها البيانات

A = 5: B = 5: C = 5: D = 5: E = 5: F = 5

Application.ScreenUpdating = False

''' بداية ونهاية صفوف الورقة المصدر

For R = 5 To 5000


'''''''''''''''''''''''''''''''''''''''''''''''''''

''تكرر الأسطر التالية لكل شيت يتم الترحيل فيه مع تغيير المتغيرات

''' رقم عمود المعيار وكلمة المعيار


If Cells(R, 4) = "1" Then

''' عدد الأعمدة التى سيتم ترحيلها

Range("A" & R).Resize(1, 9).Copy

''' سيتم اللصق في هذا الشيت

Sheets("1").Range("A" & A).PasteSpecial xlPasteValues

Application.CutCopyMode = False

A = A + 1

			 End If


If Cells(R, 4) = "2" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("2").Range("A" & B).PasteSpecial xlPasteValues

Application.CutCopyMode = False

B = B + 1

			 End If


If Cells(R, 4) = "3" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("3").Range("A" & C).PasteSpecial xlPasteValues

Application.CutCopyMode = False

C = C + 1

			 End If


If Cells(R, 4) = "4" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("4").Range("A" & D).PasteSpecial xlPasteValues

Application.CutCopyMode = False

D = D + 1

			 End If


If Cells(R, 4) = "5" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("5").Range("A" & E).PasteSpecial xlPasteValues

Application.CutCopyMode = False

E = E + 1

			 End If


If Cells(R, 4) = "6" Then

Range("A" & R).Resize(1, 9).Copy

Sheets("6").Range("A" & F).PasteSpecial xlPasteValues

Application.CutCopyMode = False

F = F + 1

			 End If


Next


MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى فصلها ")


	 For k = 1 To 6

			 y = Sheets(k).[A3000].End(xlUp).Row - 4

			 mssg = mssg & Chr(10) & Format(y, "00") & " Students to Sheet : " & k

	 Next k

MsgBox (" تم ترحيل عدد" & mssg)

	 Range("a1").Select


	 For J = 1 To 6

		 Sheets(J).[A5] = 1

		 rrw = Sheets(J).[A3000].End(xlUp).Row

		 For Each cc In Sheets(J).Range("A6:A" & rrw)

			 cc.Value = cc.Offset(-1, 0) + 1

		 Next cc

	 Next J


Application.ScreenUpdating = True


End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''

أرجو أني وفقت في تعديل الكود....

أخوك بن علية

تم تعديل بواسطه بن علية حاجي
رابط هذا التعليق
شارك

إن شاء الله وفقت يا أخى الغالى وجارى التجربة والف شكر لك يا الغلا وكل عام وأنت بخير جعل الله ايامك كلها أعياد

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

تم إستخدام الكود كما يلى وكل شئ تمام ما عدا رسالة الإحصاء التى تظهر بعد الترحيل

فهى تكون سالب 3 فى كل البيانات

والسلسلة تم إنجازها تمام والحمدلله

المطلوب تعديل الجزء الأخير من الكود الذى يقوم بإخراج الإحصائية فى مسدج بوكس


		 For J = 1 To 7

				 Sheets(J).[B5] = 1

				 rrw = Sheets(J).[A3000].End(xlUp).Row

				 For Each cc In Sheets(J).Range("B6:B" & rrw)

						 cc.Value = cc.Offset(-1, 0) + 1

				 Next cc

		 Next J

MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى فصلها ")

		 For k = 1 To 6

						 y = Sheets(k).[A3000].End(xlUp).Row - 4

						 mssg = mssg & Chr(10) & Format(y, "00") & " Students to Sheet : " & k

		 Next k

MsgBox (" تم ترحيل عدد" & mssg)

		 Range("a1").Select


Application.ScreenUpdating = True

End Sub

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

السلام عليكم ورحمة الله

أخي الكريم، أعتقد أن الخلل في السطر For k = 1 To 6

من المفروض أن يكون : For k = 1 To 7

وهذا حسب ما لاحظت في كود عمل أرقام التسلسل في شيتات الترحيل...

والسطران :

rrw = Sheets(J).[A3000].End(xlUp).Row

و

y = Sheets(k).[A3000].End(xlUp).Row - 4

ألا ينبغي أن يكونا :

rrw = Sheets(J).[B3000].End(xlUp).Row

و

y = Sheets(k).[B3000].End(xlUp).Row - 4

لست أدري إن كانت هذه الملاحظات تصحح الخلل لأنه دون ملف تجريبي لا يمكن معرفة موطن الخلل وحسن عمل الأكواد....

أخوك بن علية

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

تم ضبط الإحصائية ولكن ليس تماماً فالكود يعتبر أن شيت البيانات (السجل) هو فصل رقم 1 ويعتبر فصل رقم 1 هو فصل رقم 2 وهكذا

المطلوب أن يسمى كل شيت بإسمه فى الإحصائية

وهناك طلب آخر لو أمكن

عند لصق البيانات اثناء الترحيل هل يمكن أن يلصقها فى عمودين مثلاً يصبح العمود الأيمن مسلسله من 1 إلى 30 والعمود الثانى من 31 إلى آخر الإحصاء حسب عدد كل فصل

علماً بأننى أحتاج أن يكون العمود A خالياً

العمود B للمسلسل أ

العمود C للاسماء أ

العمود D لرقم الفصل أ

الأعمدة E و F و G و H خالية

العمود I للمسلسل ب

العمود J للاسماء ب

العمود K لرقم الفصل ب

الأعمدة L و M وN و O خالية

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

هل هذا ممكن ؟

مرفق الملف

يوسف ترحيل.rar

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

السلام عليكم ورحمة الله

أخي الكريم، بعض التعديلات تمت على ترتيب أوراق المستند (لأجل الإحصائيات) ثم تعديلات أخرى على الكود (إضافة + ترتيب بين كود الإحصائيات والترقيم التسلسلي)... الكل في الملف المرفق...

أخوك بن علية

يوسف ترحيل.rar

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

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

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



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

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

Important Information