عامر ياسر قام بنشر أغسطس 2, 2016 قام بنشر أغسطس 2, 2016 السلام عليكم الى اساتذة المنتدى الكرام : الشرح موجود بالملف ترحيل البيانات نصفين متساويين.rar
ابو عبدالبارى قام بنشر أغسطس 2, 2016 قام بنشر أغسطس 2, 2016 1 ساعه مضت, عامر ياسر said: السلام عليكم الى اساتذة المنتدى الكرام : الشرح موجود بالملف ترحيل البيانات نصفين متساويين.rar الأخ الكريم عامر ياسر بعد السلام عليكم جرب المرفق التالى abo_abary_ترحيل البيانات نصفين متساويين.rar 2
عامر ياسر قام بنشر أغسطس 2, 2016 الكاتب قام بنشر أغسطس 2, 2016 4 دقائق مضت, ابو عبدالبارى said: الأخ الكريم عامر ياسر بعد السلام عليكم جرب المرفق التالى abo_abary_ترحيل البيانات نصفين متساويين.rar شكرا لك استاذ ابو عبدالبارى انت مبدع هذا هو المطلوب دعائي لك بالتوفيق وان يجزيك الله خيرا لما تقدمه لنا من حلول سهلت لنا عملنا من خلال ابداعك يامحترم ادعوا الله سبحانه وتعالى ان يسهل لك حياتك لما فيه خير لك ابدعت ولك كل احترامي وتقديري ابدعت ولك كل احترامي وتقديري ابدعت ولك كل احترامي وتقديري ابدعت ولك كل احترامي وتقديري ابدعت ولك كل احترامي وتقديري ابدعت ولك كل احترامي وتقديري
سليم حاصبيا قام بنشر أغسطس 2, 2016 قام بنشر أغسطس 2, 2016 جرب هذا الماكرو Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim My_num, Lr, m As Integer m = 5 Set Sh1 = Sheets("البيانات"): Set Sh2 = Sheets("الناجحون") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh2.Range("A5:J500").ClearContents Sh1.Activate Lr = Application.Max(Sh1.Range("a2", Range("a" & Rows.Count).End(3))) My_num = Lr \ 2 + Lr Mod (2) Sh1.Range("a5").Resize(My_num, 6).Copy Sh2.Range("a" & m).PasteSpecial (xlValues) Application.CutCopyMode = False Sh1.Range("a5").Offset(My_num).Resize(Lr - My_num, 6).Copy Sh2.Range("f" & m).PasteSpecial (xlValues) Sh2.Select Sh2.Range("a5").Select Sh1.Select Sh1.Range("a5").Select Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub 2
عامر ياسر قام بنشر أغسطس 2, 2016 الكاتب قام بنشر أغسطس 2, 2016 6 ساعات مضت, سليم حاصبيا said: جرب هذا الماكرو Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim My_num, Lr, m As Integer m = 5 Set Sh1 = Sheets("البيانات"): Set Sh2 = Sheets("الناجحون") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh2.Range("A5:J500").ClearContents Sh1.Activate Lr = Application.Max(Sh1.Range("a2", Range("a" & Rows.Count).End(3))) My_num = Lr \ 2 + Lr Mod (2) Sh1.Range("a5").Resize(My_num, 6).Copy Sh2.Range("a" & m).PasteSpecial (xlValues) Application.CutCopyMode = False Sh1.Range("a5").Offset(My_num).Resize(Lr - My_num, 6).Copy Sh2.Range("f" & m).PasteSpecial (xlValues) Sh2.Select Sh2.Range("a5").Select Sh1.Select Sh1.Range("a5").Select Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub شكرا استاذ سليم حاصبيا جزاك الله خيرا ً على مساعدتنا في الاجابة وجعله الله في ميزان حسناتك شكرا والف شكر 1
ياسر خليل أبو البراء قام بنشر أغسطس 6, 2016 قام بنشر أغسطس 6, 2016 أخي الكريم عامر ياسر إثراءً للموضوع .. كنت قد قدمت من فترة موضوع بنفس الفكرة على الرابط التالي الرابط من هنا وقمت بعمل بعض التعديلات ليتناسب الكود مع ملفك .. إليك الكود التالي ويوضع في موديول عادي Sub SplitList() 'تعريف المتغيرات Dim shSource As Worksheet, shTarget As Worksheet Dim rList As Range, rListA As Range, rListB As Range Dim hCount As Long, tCount As Long Const colNum As Integer = 5 'عدد أعمدة النطاق المراد عمل إنشطار له 'تعيين ورقة العمل المصدر التي تحتوي القائمة الرئيسية وورقة العمل الهدف Set shSource = Sheets("البيانات") Set shTarget = Sheets("الناجحون") 'تعيين النطاق الذي يحتوي على القائمة المراد شطرها Set rList = shSource.Range("A5:A" & shSource.Cells(Rows.Count, "B").End(xlUp).Row) 'تعيين بداية النطاق للشطر الأول من القائمة Set rListA = shTarget.Range("A5") 'تعيين بداية النطاق للشطر الثاني من القائمة Set rListB = rListA.Offset(, colNum) 'تعيين قيمة المتغير ليساوي عدد خلايا النطاق المصدر tCount = rList.Cells.Count 'تعيين قيمة للمتغير ليساوي تقريب قيمة قسمة المتغير السابق ÷ 2 hCount = Round(tCount / 2, 0) 'مسح النطاق الذي ستظهر فيه النتائج للشطر الأول والشطر الثاني shTarget.Range("A4:J10000").ClearContents 'وضع نتائج الشطر الأول rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value 'وضع نتائج الشطر الثاني rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value MsgBox "Done ..." & vbNewLine & "Best Regards" & Chr(10) & "YasserKhalil", 64 End Sub تقبل تحياتي 2
عامر ياسر قام بنشر أغسطس 6, 2016 الكاتب قام بنشر أغسطس 6, 2016 (معدل) 40 دقائق مضت, ياسر خليل أبو البراء said: أخي الكريم عامر ياسر إثراءً للموضوع .. كنت قد قدمت من فترة موضوع بنفس الفكرة على الرابط التالي الرابط من هنا وقمت بعمل بعض التعديلات ليتناسب الكود مع ملفك .. إليك الكود التالي ويوضع في موديول عادي Sub SplitList() 'تعريف المتغيرات Dim shSource As Worksheet, shTarget As Worksheet Dim rList As Range, rListA As Range, rListB As Range Dim hCount As Long, tCount As Long Const colNum As Integer = 5 'عدد أعمدة النطاق المراد عمل إنشطار له 'تعيين ورقة العمل المصدر التي تحتوي القائمة الرئيسية وورقة العمل الهدف Set shSource = Sheets("البيانات") Set shTarget = Sheets("الناجحون") 'تعيين النطاق الذي يحتوي على القائمة المراد شطرها Set rList = shSource.Range("A5:A" & shSource.Cells(Rows.Count, "B").End(xlUp).Row) 'تعيين بداية النطاق للشطر الأول من القائمة Set rListA = shTarget.Range("A5") 'تعيين بداية النطاق للشطر الثاني من القائمة Set rListB = rListA.Offset(, colNum) 'تعيين قيمة المتغير ليساوي عدد خلايا النطاق المصدر tCount = rList.Cells.Count 'تعيين قيمة للمتغير ليساوي تقريب قيمة قسمة المتغير السابق ÷ 2 hCount = Round(tCount / 2, 0) 'مسح النطاق الذي ستظهر فيه النتائج للشطر الأول والشطر الثاني shTarget.Range("A4:J10000").ClearContents 'وضع نتائج الشطر الأول rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value 'وضع نتائج الشطر الثاني rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value MsgBox "Done ..." & vbNewLine & "Best Regards" & Chr(10) & "YasserKhalil", 64 End Sub تقبل تحياتي السلام عليكم استاذ ياسر خليل أبو البراء ........ شكرا لاجابتكم الرائعة وقد افتقدت اجاباتك منذ فترة . بخصوص الموضوع انا اثناء عملي تأتيني بعض الافكار التي هي من صلب عملي التجئ اليكم والى هذا المنتدى والصرح الرائع الذي وجدت فيه اجابات غاية في الابداع ولم تبخلوا علينا بأي معلومة وانا من المتابعين بصورة مستمرة بحيث اقضي معظم وقتي في تصفح هذا المنتدى ومشاركاته واجاباتكم الرائعة . شكري وتقديري لشخصكم الكريم . ابدعت في الاجابة والشرح الوافي تم تعديل أغسطس 6, 2016 بواسطه عامر ياسر 1
ياسر خليل أبو البراء قام بنشر أغسطس 6, 2016 قام بنشر أغسطس 6, 2016 وعليكم السلام أخي العزيز عامر الحمد لله أن تم المطلوب على خير وإن شاء الله ستستفيد الكثير والكثير من المنتدى ونصيحة حاول أن تعطي وستجد نفسك في طريق التعلم .. العطاء خير وسيلة للتعلم تقبل وافر تقديري واحترامي 2
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.