كود ترحيل بيانات بشرط .. ولا أسهل

[محمدي عبد السميع]

بسم الله الرحمن الرحيم

الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ،

تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ،

الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار،

وشغلهم بمراقبته وإدامة الأفكار ،

وملازمة الاتعاظ والادكار،

ووفقهم للدؤوب في طاعته والتأهب لدار القرار،

والحذر مما يسخطه ويوجب دار البوار،

والمحافظة على ذلك مع تغاير الأحوال والأطوار.

أحمده أبلغ حمد وأزكاه، وأشمله وأنماه.

أما بعد:

رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته

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

ولهذا ساقدم

سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له

في موضوع مستقل

وسأشرح كيفية استخدام الكود ماتيسر لي

إن شاء الله

وعلى الله قصد السبيل

******************************************

هذا

كود ترحيل الصفحة كامله بشرط واحد

على سبيل المثال

عندنا درجات الطلاب وفيهم طلاب ناجحون وطلاب دور ثان وطلاب راسبون

هذا الكود يفصل الطلاب الناجحون في ورقة ويفصل الطلاب الذين لهم حق الدخول في الدور الثاني في صفحة أخرى

ويفصل الطلاب الراسبون في صفحة أخرى

وهكذا

طريقة الاستفادة من الكود

افتح ملف اكسيل

اضغط على الرز ALT وانت ضاغط على الزر

اضغط على F11 الموجود أعلا لوحة المفاتيح

ستظهر شاشة الماكرو

اضغط على موديول 1

سيتم فتح الموديول

الصق فيه الكود الموجود

تحت هذا السطر

Sub KH_START()[/center]


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

Dim R As Integer, M As Integer, N As Integer, O As Integer

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

	Sheets("ناجح").Range("A11:DZ1000").ClearContents

	Sheets("دور ثان في").Range("A11:DZ1000").ClearContents

	Sheets("رسوب").Range("A11:DZ1000").ClearContents


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

	M = 11: N = 11: O = 12

	Application.ScreenUpdating = False


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

	For R = 11 To 1000


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


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

		If Cells(R, 113) = "ناجح" Then

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


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

			Sheets("ناجح").Range("A" & M).PasteSpecial xlPasteValues

			Application.CutCopyMode = False

			M = M + 1



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


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

			ElseIf Cells(R, 113) = "دور ثان في" Then

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


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

			Sheets("دور ثان في").Range("A" & N).PasteSpecial xlPasteValues

			Application.CutCopyMode = False


					'''  اجعل الرقم 1  الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل

			N = N + 1

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


			ElseIf Cells(R, 113) = "رسوب" Then

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

			Sheets("رسوب").Range("A" & O).PasteSpecial xlPasteValues

			Application.CutCopyMode = False


				  '''  لترك صف فارغ اعلا كل صف

			O = O + 2

		End If


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


	Next


	MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ")

	Application.ScreenUpdating = True

End Sub

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

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

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

			ElseIf Cells(R, 113) = "دور ثان في" Then

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


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

			Sheets("دور ثان في").Range("A" & N).PasteSpecial xlPasteValues

			Application.CutCopyMode = False


					'''  اجعل الرقم 1  الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل

			N = N + 1

ودمتم في حفظ الله

ترحيل مفيد جدا كل الصفحة بشرط.rar

[نايف - م]

شكرا- شرح جميل و مفصل

[أبو حنــــين]

السلام عليكم

بارك الله فيك اخي محمدي

عمل ممتاز و سيستفيد منه الكثيرون

[عبدالله المجرب]

احسنت اخي محمدي

ويجدر الاشارة الى ان هذا الكود للعلامة عبدالله باقشير

وهنا طريقة اضافة كود للمكتبة

[محمدي عبد السميع]

اشكرك اخي عبد الله

على شرحك الوافي .. ولكن عند تسلسل الخطوات معي تظهر هذه الشاشة التي لاتمكنني من الاضافة

[ahmd_asd4]

الأخوة الأساتذة الأجلاء كل عام و أنتم بخير بعد التحية

فأنا طفل أحبو متعلما في هذا المنتدى العملاق

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

أريد بعد إزنكم : رؤية كود الترحيل فهو في الأساس للأستاذ الخبير جدا خبور و قمت فيه بما سترونه من تركيب ( عك مني )

1- ترحيل الطلاب حسب التخصصات في العمود 4 من صفحة الشيت

2- عمل زر بالضغط عليه يقوم بعمنلية الترحيل

3- تكون عملية الترحيل مرنة بحيث ممكن أن أمسح و أعيد الترحيل أكثر من مرة كما في كود الأستاذ خبور الأصلي

أسف للإطالة عليكم و لكن أعرف سعة صدوركم فهي من شيمة العلماء

التنسيق الجديدش ط.rar

[ابو بهاء المصري]

بارك الله فيك اخي محمدي

عمل ممتاز

[abdelmoneeim]

جزاك الله خيرا فكرة رائعة وممتازة

[محمدي عبد السميع]

Sub كشف_دور_ثاني()
On Error Resume Next
Dim T As Integer, Y As Integer, Z As Integer, V As Integer _
, N As Integer, X As Integer, R As Integer, M As Integer _
, C As Integer, CC As Integer

مسح_كشف_دور_ثاني

T = Application.CountIf(Sheet1.Range("DI11:DI1000"), "دور ثاني") / 30
'================================
Application.ScreenUpdating = False
With ActiveSheet
    Y = (T * 38) + 39
    .PageSetup.PrintArea = Range("B2:N" & Y).Address
End With
'================================
Z = 40
Range("نموذج_كشف2").Copy
For V = 1 To T
    Range("B" & Z).PasteSpecial xlPasteAll
    Set ActiveSheet.HPageBreaks(V).Location = Range("B" & Z)
    Z = Z + 38
Next V
Application.CutCopyMode = False
'================================
N = 6
With Sheet1
    X = .Range("A" & .Rows.Count).End(xlUp).Row
    For R = 11 To X
        If .Range("CZ" & R) <> "ناجح" Then
            M = M + 1
            Cells(M + N, 2) = M
            For C = 1 To 12
                CC = Choose(C, 3, 2, 26, 35, 44, 53, 64, 69, 74, 84, 94)
                Cells(M + N, C + 2) = .Cells(R, CC)
            Next C
            If M Mod 30 = 0 Then N = N + 8
        End If
    Next R
End With
Range("A2").Activate
'================================
Application.ScreenUpdating = True
MsgBox "تم ترحيل   " & M & "   طالب دور ثاني", vbMsgBoxRight, "الحمدلله"
معاينة
On Error GoTo 0
End Sub
Sub مسح_كشف_دور_ثاني()
Dim Y As Integer
Application.ScreenUpdating = False
    With ActiveSheet
        Y = .UsedRange.Rows.Count + 40
        .Rows("40:" & Y).Delete
        Range("نموذج_كشف2").Offset(5, 0).Resize(30, 13).ClearContents
        .PageSetup.PrintArea = Range("نموذج_كشف2").Address
    End With
    ActiveWindow.ScrollRow = 2
End Sub
Sub معاينة()
   ActiveWindow.SelectedSheets.PrintPreview
End Sub

كود رائع للترحيل

ترحيل مفيد.rar

[حمادة عمر]

السلام عليكم

اخي الكريم / محمدي عبد السميع

 

بارك الله فيك

بالفعل شروحات ممتاااازه

جعلها الله في ميزان حسناتك

والشكر موصول للكبير القدير العلامة الخبير / عبد الله باقشير

جزاكم الله خيرا

[قصي]

لو تكرمتم

نريد كتابة بعض الاسطر باللون الاخضر في الكود لمساعدتنا في فهم ونغيير الكود

[محمدي عبد السميع]

تفضل اخي الكريم

Sub كشف_دور_ثاني()

 'عند الخطأ تخطاه
On Error Resume Next

 'عشر متغبرات
Dim T As Integer, Y As Integer, Z As Integer, V As Integer _
, N As Integer, X As Integer, R As Integer, M As Integer _
, C As Integer, CC As Integer

مسح_كشف_دور_ثاني

 'اسم شيت المصدر وعمود الترحيل والمعيار .. من شيت المصدر
T = Application.CountIf(Sheet1.Range("DI11:DI1000"), "ناجح") / 30
'================================
Application.ScreenUpdating = False
With ActiveSheet
    Y = (T * 38) + 39
    
    'اعمدة منطقة الطباعه
    .PageSetup.PrintArea = Range("B2:N" & Y).Address
End With
'================================
Z = 40
Range("نموذج_كشف2").Copy
For V = 1 To T
    Range("B" & Z).PasteSpecial xlPasteAll
    Set ActiveSheet.HPageBreaks(V).Location = Range("B" & Z)
    Z = Z + 38
Next V
Application.CutCopyMode = False
'================================

'بداية صف الترحيل الى الشيت الهدف
N = 6

' اسم شيت المصدر
With Sheet1
    X = .Range("A" & .Rows.Count).End(xlUp).Row
    
 'بداية صف الترحيل من الشيت المصدر
    For R = 11 To X
    
     'عمود المعيار والمعيار من الشيت المصدر
        If .Range("DI" & R) = "ناجح" Then
            M = M + 1
            Cells(M + N, 2) = M
            
             'عدد اعمدة الترحيل من الشيت المصدر
            For C = 1 To 12
            
             'اعمدة الترحيل من الشيت المصدر
                CC = Choose(C, 3, 2, 26, 35, 44, 53, 64, 69, 74, 84, 94)
                Cells(M + N, C + 2) = .Cells(R, CC)
            Next C
            If M Mod 30 = 0 Then N = N + 8
        End If
    Next R
End With
Range("A2").Activate
'================================
Application.ScreenUpdating = True
MsgBox "تم ترحيل   " & M & " طالب ناجح ", vbMsgBoxRight, "الحمدلله"
معاينة
On Error GoTo 0
End Sub
Sub مسح_كشف_دور_ثاني()
Dim Y As Integer
Application.ScreenUpdating = False
    With ActiveSheet
        Y = .UsedRange.Rows.Count + 40
        .Rows("40:" & Y).Delete
        Range("نموذج_كشف2").Offset(5, 0).Resize(30, 13).ClearContents
        .PageSetup.PrintArea = Range("نموذج_كشف2").Address
    End With
    ActiveWindow.ScrollRow = 2
End Sub
Sub معاينة()
   ActiveWindow.SelectedSheets.PrintPreview
End Sub

[قصي]

جزاك الله كل خير

[على عبدالراضى]

الاستاذ/ محمدى

السلام عليكم ورحمتة اللة وبركاتة

انا عضو جديد فى المنتدى وقد اعجبنى العمل الرائع الذى قمت بعملة وهو كود الترحيل ولكن عند محاولة التطبيق  لة فقد فشلت  لذلك ارجو منك بعد اذنك شرح لبعض النقاط مثل o& m & nماهو المقصود بهم ولوسمحت لى بان تعرفنى معنى المعيار واحب ان اضيف لك اننى لى شيت يحتوى على 16 تخصص مختلف فكيف اعمل لهم كود الترحيل وانا اسف على الاطالة ولكن عملك المتميز هو الذى جعلنى اطلب منك هذا الطلب مرفق ملف به مجموعة من التخصصات وشكرا لكم واسف على الاطالة

كنتزول2013.rar

[أم عبد الله]

الأستاذ / محمدي عبد السميع

 

جزاك الله خيراً على هذا الشرح الوافي لتعليم كيفية الترحيل وجزاه الله خيراً أستاذنا العلاّمة القدير / عبد الله باقشير  وجاه الله خيراً أستاذنا الفاضل عبد الله المجرب على الفيديو . جعل الله أعمالكم في ميزان حسناتكم.

[قصي]

Sub Tarheel()
Dim i As Integer, x As Integer
Dim lr As Integer, y As Integer
lr = [b10000].End(xlUp).Row
Sheets("ناجحون").Range("a9:ho1000").ClearContents
Sheets("راسبون").Range("a9:ho1000").ClearContents
Application.ScreenUpdating = False
x = 9: y = 9
For i = 9 To lr
    If Cells(i, 3).Value = "ناجح" And Cells(i, 4) <> " " Then
        Range("a" & i).Resize(1, 223).Copy
        Sheets("ناجحون").Range("a" & x).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        x = x + 1
    ElseIf Cells(i, 3).Value = "له دور ثان" And Cells(i, 4) <> " " Then
        Range("a" & i).Resize(1, 223).Copy
        Sheets("راسبون").Range("a" & y).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        y = y + 1
    End If
Next i
MsgBox "تم بحمد الله فصل الناجحين والراسبين فى كشوف منفصلة", vbOKOnly, "ترحيل الناجحون والراسبون"
Application.ScreenUpdating = True
End Sub

بداية الكود
                                 Sub Tarheel()
السطور التالية خاصة بتعيين متغيرات لتخزين البيانات من نوع أرقام صحيحة Integer
Dim i As Integer, x As Integer
Dim lr As Integer, y As Integer

السطر التالى لتحديد اخر صف يحتوى على بيانات 
                               lr = [b10000].End(xlUp).Row

السطرين التاليين لمسح بيانات صفحة ناجحون وراسبون قبل نسخ البيانات اليهما 
Sheets("ناجحون").Range("a9:ho1000").ClearContents
Sheets("راسبون").Range("a9:ho1000").ClearContents

السطر التالى يعمل على ايقاف اهتزاز الشاشة ( لتسريع الكود ) 
Application.ScreenUpdating = False

السطر التالى يعطى قيمة للمتغيرين x   و  y   وهى تساوى 9 ( أول صف يتم فيه لصق البيانات المنسوخة فى صفحة ( ناجحون ) وصفحة (  راسبون )
x = 9: y = 9


السطر التالى بداية حلقة تكرارية تبدأ من الصف التاسع الى lr  ( اخر صف يحتوى على بيانات  )
                              For i = 9 To lr

وتنتهى هذه الحلقة التكرارية بالكلمة next 

السطر التالى يختبر قيمة الخلية المحتوية على نتيجة الطالب 

                          If Cells(i, 3).Value = "ناجح" And Cells(i, 4) <> " " Then
فاذا كانت تحتوى على كلمة ناجح وخلية اسم الطالب ليست فارغة  يقوم بنسخ الصف بالكامل الذى توجد فيه الخلية  عن طريق السطر التالى 
                          Range("a" & i).Resize(1, 223).Copy
السطر التالى يعمل على لصق البيانات المنسوخة الى الصفحة ( ناجحون ) 
                         Sheets("ناجحون").Range("a" & x).PasteSpecial xlPasteValues 
السطر التالى يعمل على ايقاف خاصية النسخ واللصق 
                        Application.CutCopyMode = False
السطر التالى يزيد قيمة المتغير  x  بمقدار واحد 
                        x = x + 1
  الجزء الباقى من الكود تكرار الخطوات السابقة ولكن مع الراسب 
السطر التالى خاص باظهار رسالة توضح اكتمال عملية فصل الناجحون والراسبون 
MsgBox "تم بحمد الله فصل الناجحين والراسبين فى كشوف منفصلة", vbOKOnly, "ترحيل الناجحون والراسبون"

السطر التالى يعيد مرة اخرى خاصية اهتزاز الشاشة 
             Application.ScreenUpdating = True
نهاية الكود
            End Sub
الشرح لاخيكم
/ رجب جاويش

[قصي]

اريد ان اجعل المستند ( الراسبون ) يتم النسخ فيه على سطر وسطر

وجزالك الله عنا خير الجزاء اخي الفاضل

 

-------------

أخى الفاضل

فى الكود فى الجزء الخاص بالراسبين غير الجزء

y = y + 1

الى الجزء

y = y + 2

 

[محمد يوسف محمد1]

تحياتى لكم أساتذة وخبراء الاكسل فى هذا المنتدى العملاق

 

شروحات ولا أروع

 

بارك الله لكم

[emmsh]

بارك الله فيكم واكثر الله من فائض علمه عليكم وعلينا 

الشرح وافى والكود رائع 

[أبو أنس80]

ما شاء الله والله لا اجد كلمات اعبر بها عن امتناني لحضرتك

جزاك الله كل خير

[عبد الحميد شقير]

كنتم خير أمة ...صدق الله العظيم ......جزاك الله خيراً ....أخي محمدي 

[ايهاب عبدالحميد]

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

 

فى البداية اشكركم على مجهوداتكم الرائعه والشروحات الوافية

ولكنى حاولت التطبيق على هذا الملف ولكن لما استطيع

اريد كود يرحل البيانات بدون حذف البيانات من الصفحة الاساسية "الكل"

اريد ترحيل من  يعملون فى مدارس الصحافة الى شيت مدارس الصحافة  الموجوده فى العمود "C"

وترحيل من يعملون فى مدارس النوابغ الى شيت مدارس النوابغ الموجوده فى العمود "C"

وجزاكم الله خيرا

الملف الجديد2.rar

[ا بو سليمان]

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

 

هل بالامكان ان  يتم اختصار  الكود  لكي يسهل فهمة 

 

لكي يتم تطبيقه   لترحيل  قيمة خلايا   عمود   الى  عمود مجاور له   وتكرار العمليه  في بقيه الاعمدة    

[nadiya]

السلام عليكم ,وعمل ممتاز وندعوا من الله ان يكون في ميزان حسانتك .....

اخي في الله ارجوا مساعدتي في عمل كود يرحل بيانات لهذا البرنامج

على ان يتم نقل بيانات المريض الى صفحته مباشرة وبصورة دورية اي عند ادخال اي متغير يتم ترحيل البيانات الجديدة اسفل القديمة في نفس صفحة المريض وشكرا لك

عيادة الدكتورة نادية -قلبيه.rar

[ا بو سليمان]

السلام عليكم ,وعمل ممتاز وندعوا من الله ان يكون في ميزان حسانتك .....

اخي في الله ارجوا مساعدتي في عمل كود يرحل بيانات لهذا البرنامج

على ان يتم نقل بيانات المريض الى صفحته مباشرة وبصورة دورية اي عند ادخال اي متغير يتم ترحيل البيانات الجديدة اسفل القديمة في نفس صفحة المريض وشكرا لك

فيه ابو حنين   ................

 

اكيد هذا الشخص    لديه القدره  على عملها  بكل سهووووووووله .........((  توهيقه ابو حنين ...هههههه.... لكن هذا جزاء كل من يختفي فجأه عن من يحبوووووونه بالله ..... )