ترحيل البيانات نصفين متساويين

[عامر ياسر]

السلام عليكم

الى اساتذة المنتدى الكرام : الشرح موجود بالملف 

ترحيل البيانات نصفين متساويين.rar

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

1 ساعه مضت, عامر ياسر said:

السلام عليكم

الى اساتذة المنتدى الكرام : الشرح موجود بالملف 

ترحيل البيانات نصفين متساويين.rar

الأخ الكريم عامر ياسر

بعد السلام عليكم

جرب المرفق التالى

abo_abary_ترحيل البيانات نصفين متساويين.rar

[عامر ياسر]

4 دقائق مضت, ابو عبدالبارى said:

الأخ الكريم عامر ياسر

بعد السلام عليكم

جرب المرفق التالى

abo_abary_ترحيل البيانات نصفين متساويين.rar

شكرا لك استاذ ابو عبدالبارى انت مبدع هذا هو المطلوب 

دعائي لك بالتوفيق وان يجزيك الله خيرا لما تقدمه لنا من حلول

سهلت لنا عملنا من خلال ابداعك يامحترم 

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

ابدعت ولك كل احترامي وتقديري 

ابدعت ولك كل احترامي وتقديري 

ابدعت ولك كل احترامي وتقديري 

ابدعت ولك كل احترامي وتقديري 

ابدعت ولك كل احترامي وتقديري 

ابدعت ولك كل احترامي وتقديري 

[سليم حاصبيا]

جرب هذا الماكرو

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

 

[عامر ياسر]

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

 

شكرا استاذ سليم حاصبيا جزاك الله خيرا ً على مساعدتنا في الاجابة وجعله الله في ميزان حسناتك شكرا والف شكر

[ياسر خليل أبو البراء]

أخي الكريم عامر ياسر

إثراءً للموضوع .. كنت قد قدمت من فترة موضوع بنفس الفكرة على الرابط التالي

الرابط من هنا

وقمت بعمل بعض التعديلات ليتناسب الكود مع ملفك ..

إليك الكود التالي ويوضع في موديول عادي

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

تقبل تحياتي

 

[عامر ياسر]

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 بواسطه عامر ياسر

[ياسر خليل أبو البراء]

وعليكم السلام أخي العزيز عامر

الحمد لله أن تم المطلوب على خير وإن شاء الله ستستفيد الكثير والكثير من المنتدى

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

تقبل وافر تقديري واحترامي