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

**يوسف عطا** · أغسطس 17, 2012

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

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


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

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

**بن علية حاجي** · أغسطس 17, 2012

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

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

أخي الكريم يوسف، لتصحيح الكود وعمله يكفي إضافة العبارة 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

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

والله أعلم

أخوك بن علية

تم تعديل أغسطس 17, 2012 بواسطه بن علية حاجي

**يوسف عطا** · أغسطس 17, 2012

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

**يوسف عطا** · أغسطس 17, 2012

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

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

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

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

علما بأن التسلسل التلقائى سيكون فى العمود 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

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

**بن علية حاجي** · أغسطس 17, 2012

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

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

أخي الكريم هذه محاولة في الكود ولكن جعلت الترقيم التلقائي للتسلسل في العمود 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

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

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

أخوك بن علية

تم تعديل أغسطس 17, 2012 بواسطه بن علية حاجي

**يوسف عطا** · أغسطس 18, 2012

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

تم تعديل أغسطس 18, 2012 بواسطه يوسف عطا

**يوسف عطا** · أغسطس 18, 2012

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

فهى تكون سالب 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

تم تعديل أغسطس 18, 2012 بواسطه يوسف عطا

**بن علية حاجي** · أغسطس 18, 2012

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

أخي الكريم، أعتقد أن الخلل في السطر 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

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

أخوك بن علية

**يوسف عطا** · أغسطس 18, 2012

الف شكر على إهتمامك بالموضوع أخى بن علية

جارى تغيير التغييرات المذكورة ولو لم يفلح الأمر سأرفق الملف

**يوسف عطا** · أغسطس 18, 2012

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

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

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

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

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

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

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

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

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

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

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

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

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

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

هل هذا ممكن ؟

مرفق الملف

يوسف ترحيل.rar

تم تعديل أغسطس 18, 2012 بواسطه يوسف عطا

**بن علية حاجي** · أغسطس 18, 2012

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

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

أخوك بن علية

يوسف ترحيل.rar

**يوسف عطا** · أغسطس 18, 2012

الف شكر يا أخى الحبيب

تسجيل الدخول

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

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

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

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

Important Information