محمدي عبد السميع قام بنشر مايو 4, 2012 قام بنشر مايو 4, 2012 بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود ترحيل الصفحة كامله بشرط واحد على سبيل المثال عندنا درجات الطلاب وفيهم طلاب ناجحون وطلاب دور ثان وطلاب راسبون هذا الكود يفصل الطلاب الناجحون في ورقة ويفصل الطلاب الذين لهم حق الدخول في الدور الثاني في صفحة أخرى ويفصل الطلاب الراسبون في صفحة أخرى وهكذا طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز 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 7
أبو حنــــين قام بنشر مايو 4, 2012 قام بنشر مايو 4, 2012 السلام عليكم بارك الله فيك اخي محمدي عمل ممتاز و سيستفيد منه الكثيرون
عبدالله المجرب قام بنشر مايو 4, 2012 قام بنشر مايو 4, 2012 احسنت اخي محمدي ويجدر الاشارة الى ان هذا الكود للعلامة عبدالله باقشير وهنا طريقة اضافة كود للمكتبة
محمدي عبد السميع قام بنشر مايو 5, 2012 الكاتب قام بنشر مايو 5, 2012 اشكرك اخي عبد الله على شرحك الوافي .. ولكن عند تسلسل الخطوات معي تظهر هذه الشاشة التي لاتمكنني من الاضافة
ahmd_asd4 قام بنشر أغسطس 3, 2012 قام بنشر أغسطس 3, 2012 الأخوة الأساتذة الأجلاء كل عام و أنتم بخير بعد التحية فأنا طفل أحبو متعلما في هذا المنتدى العملاق برجاء المساعدة في الملف الرفق فهو تنسيق عملته لمدرستي لتوزيع الطلاب على الأقسام أريد بعد إزنكم : رؤية كود الترحيل فهو في الأساس للأستاذ الخبير جدا خبور و قمت فيه بما سترونه من تركيب ( عك مني ) 1- ترحيل الطلاب حسب التخصصات في العمود 4 من صفحة الشيت 2- عمل زر بالضغط عليه يقوم بعمنلية الترحيل 3- تكون عملية الترحيل مرنة بحيث ممكن أن أمسح و أعيد الترحيل أكثر من مرة كما في كود الأستاذ خبور الأصلي أسف للإطالة عليكم و لكن أعرف سعة صدوركم فهي من شيمة العلماء التنسيق الجديدش ط.rar
محمدي عبد السميع قام بنشر أبريل 3, 2013 الكاتب قام بنشر أبريل 3, 2013 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
حمادة عمر قام بنشر أبريل 3, 2013 قام بنشر أبريل 3, 2013 السلام عليكم اخي الكريم / محمدي عبد السميع بارك الله فيك بالفعل شروحات ممتاااازه جعلها الله في ميزان حسناتك والشكر موصول للكبير القدير العلامة الخبير / عبد الله باقشير جزاكم الله خيرا
قصي قام بنشر أبريل 5, 2013 قام بنشر أبريل 5, 2013 لو تكرمتم نريد كتابة بعض الاسطر باللون الاخضر في الكود لمساعدتنا في فهم ونغيير الكود
محمدي عبد السميع قام بنشر أبريل 5, 2013 الكاتب قام بنشر أبريل 5, 2013 تفضل اخي الكريم 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
على عبدالراضى قام بنشر مايو 21, 2013 قام بنشر مايو 21, 2013 الاستاذ/ محمدى السلام عليكم ورحمتة اللة وبركاتة انا عضو جديد فى المنتدى وقد اعجبنى العمل الرائع الذى قمت بعملة وهو كود الترحيل ولكن عند محاولة التطبيق لة فقد فشلت لذلك ارجو منك بعد اذنك شرح لبعض النقاط مثل o& m & nماهو المقصود بهم ولوسمحت لى بان تعرفنى معنى المعيار واحب ان اضيف لك اننى لى شيت يحتوى على 16 تخصص مختلف فكيف اعمل لهم كود الترحيل وانا اسف على الاطالة ولكن عملك المتميز هو الذى جعلنى اطلب منك هذا الطلب مرفق ملف به مجموعة من التخصصات وشكرا لكم واسف على الاطالة كنتزول2013.rar
أم عبد الله قام بنشر مايو 22, 2013 قام بنشر مايو 22, 2013 الأستاذ / محمدي عبد السميع جزاك الله خيراً على هذا الشرح الوافي لتعليم كيفية الترحيل وجزاه الله خيراً أستاذنا العلاّمة القدير / عبد الله باقشير وجاه الله خيراً أستاذنا الفاضل عبد الله المجرب على الفيديو . جعل الله أعمالكم في ميزان حسناتكم.
قصي قام بنشر يونيو 9, 2013 قام بنشر يونيو 9, 2013 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 الشرح لاخيكم / رجب جاويش 1
قصي قام بنشر يونيو 9, 2013 قام بنشر يونيو 9, 2013 اريد ان اجعل المستند ( الراسبون ) يتم النسخ فيه على سطر وسطر وجزالك الله عنا خير الجزاء اخي الفاضل ------------- أخى الفاضل فى الكود فى الجزء الخاص بالراسبين غير الجزء y = y + 1 الى الجزء y = y + 2
محمد يوسف محمد1 قام بنشر يونيو 28, 2013 قام بنشر يونيو 28, 2013 تحياتى لكم أساتذة وخبراء الاكسل فى هذا المنتدى العملاق شروحات ولا أروع بارك الله لكم
emmsh قام بنشر يونيو 28, 2013 قام بنشر يونيو 28, 2013 بارك الله فيكم واكثر الله من فائض علمه عليكم وعلينا الشرح وافى والكود رائع
أبو أنس80 قام بنشر يوليو 1, 2013 قام بنشر يوليو 1, 2013 ما شاء الله والله لا اجد كلمات اعبر بها عن امتناني لحضرتك جزاك الله كل خير
عبد الحميد شقير قام بنشر أكتوبر 6, 2013 قام بنشر أكتوبر 6, 2013 كنتم خير أمة ...صدق الله العظيم ......جزاك الله خيراً ....أخي محمدي 1
ايهاب عبدالحميد قام بنشر ديسمبر 12, 2013 قام بنشر ديسمبر 12, 2013 السلام عليكم ورحمة الله وبركاته فى البداية اشكركم على مجهوداتكم الرائعه والشروحات الوافية ولكنى حاولت التطبيق على هذا الملف ولكن لما استطيع اريد كود يرحل البيانات بدون حذف البيانات من الصفحة الاساسية "الكل" اريد ترحيل من يعملون فى مدارس الصحافة الى شيت مدارس الصحافة الموجوده فى العمود "C" وترحيل من يعملون فى مدارس النوابغ الى شيت مدارس النوابغ الموجوده فى العمود "C" وجزاكم الله خيرا الملف الجديد2.rar
ا بو سليمان قام بنشر أبريل 5, 2014 قام بنشر أبريل 5, 2014 السلام عليكم ورحمة الله هل بالامكان ان يتم اختصار الكود لكي يسهل فهمة لكي يتم تطبيقه لترحيل قيمة خلايا عمود الى عمود مجاور له وتكرار العمليه في بقيه الاعمدة
nadiya قام بنشر أبريل 6, 2014 قام بنشر أبريل 6, 2014 السلام عليكم ,وعمل ممتاز وندعوا من الله ان يكون في ميزان حسانتك ..... اخي في الله ارجوا مساعدتي في عمل كود يرحل بيانات لهذا البرنامج على ان يتم نقل بيانات المريض الى صفحته مباشرة وبصورة دورية اي عند ادخال اي متغير يتم ترحيل البيانات الجديدة اسفل القديمة في نفس صفحة المريض وشكرا لك عيادة الدكتورة نادية -قلبيه.rar
ا بو سليمان قام بنشر أبريل 6, 2014 قام بنشر أبريل 6, 2014 السلام عليكم ,وعمل ممتاز وندعوا من الله ان يكون في ميزان حسانتك ..... اخي في الله ارجوا مساعدتي في عمل كود يرحل بيانات لهذا البرنامج على ان يتم نقل بيانات المريض الى صفحته مباشرة وبصورة دورية اي عند ادخال اي متغير يتم ترحيل البيانات الجديدة اسفل القديمة في نفس صفحة المريض وشكرا لك فيه ابو حنين ................ اكيد هذا الشخص لديه القدره على عملها بكل سهووووووووله .........(( توهيقه ابو حنين ...هههههه.... لكن هذا جزاء كل من يختفي فجأه عن من يحبوووووونه بالله ..... )
الردود الموصى بها