ترحيل البيانات كارشيف من مصنف الى مصنف اخر

[أبو محمد عباس]

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

الاساتذة الافاضل والاخوة الاعزاء جزاكم الله خيرا

الملف المرفق فيه ورقة النتائج مع الشهادات والعشرة الاوائل وهو جاهز لمن يريد ان يعمل عليه فقط يقوم بتنزيل الدرجات كما موجود في الملف

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

ولكم فائق الاحترام والتقدير

النتائج مع الارشيف.rar

[أبو محمد عباس]

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

الاساتذة الكرام جزاكم الله خيرا

الحقيقة انا شاهدت ملف للاستاذ العالم العلامة الاستاذ الفاضل عبد الله باقشير حفظه الله ودام عزه واعلى الله مقامه على هذا الرابط http://www.officena.net/ib/index.php?showtopic=29935#

وهو ترحيل فاتورة الى ملف اخر للعملاء وكان رائعا لكن اردت ان اعدل عليه ولو قليلا ليتناسب مع ملفي  ولكن هناك اختلاف من حيث الشرط ( ناجح) وغيره من طلباتي التي تختلف عن الكود المذكور ولكن اردت ان اوصل الفكرة حول امكانية ادراج السنة الدراسية والدور من خلية واحدة كما في كود العلامة الاستاذ ابو علي دام عزه حيث يقوم الكود بادراج التاريخ من خلية واحده (J6 ) في عمود ( A )

وحاولت ان اطبق ملف الاستاذ ابو احمد عبد الله المجرب حفظه الله واعطاه الصحة والعافية على هذا الرابط  http://www.officena.net/ib/index.php?showtopic=41919&page=8#entry304066

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

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

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

 

الترحيل الى ورقة البيانات.rar

[عبدالله باقشير]

السلام عليكم

 

بالنسبة للترحيل الى ورقة البيانات

Sub trheel()
Dim cl As Range
Dim Lr As Long, i As Long

With Sheets("البيانات")
    Lr = .Cells(Rows.Count, "B").End(xlUp).Row
    For Each cl In Range("o3:o" & [o10000].End(xlUp).Row)
        If cl.Value = "ناجح" Then
            i = i + 1
            .Cells(Lr + i, "B").Resize(1, 13).Value = cl.Offset(0, -13).Resize(1, 13).Value
            .Cells(Lr + i, "O").Value = [I1]
            .Cells(Lr + i, "P").Value = [M1]
            
        End If
    Next
End With

End Sub

اما المسح اظن انك تقصد به حذف الصف

لان المسح سيبقي الفراغات

 

جرب الكود اولا

 

تحياتي

[أبو محمد عباس]

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

الاستاذ والعالم العلامة عبد الله باقشير حفظكم الباري عز وجل ورعاكم

كود رائع وهو المطلوب بارك الله فيك واعزك واكرمك واعلى مقامك في الدارين

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

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

وفقكم الله وزادكم من فضله علما وشرفا

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

الترحيل الى ورقة البيانات++.rar

 

 

[عبدالله باقشير]

السلام عليكم

 

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

 

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

 

جرب التالي

Sub trheel()
Dim cel As Range
Dim Lr As Long, R As Long, i As Long, iCont As Long

With Sheets("البيانات")
    Lr = .Cells(Rows.Count, "B").End(xlUp).Row
    iCont = WorksheetFunction.Max(.Range("A3").Resize(Lr))
    
    For R = 3 To Cells(Rows.Count, "D").End(xlUp).Row
        If Cells(R, "O").Value = "ناجح" Then
            i = i + 1
            .Cells(Lr + i, "A").Value = iCont + i
            .Cells(Lr + i, "B").Resize(1, 13).Value = Cells(R, "B").Resize(1, 13).Value
            .Cells(Lr + i, "O").Value = [I1]
            .Cells(Lr + i, "P").Value = [M1]
            If cel Is Nothing Then Set cel = Cells(R, "A") Else Set cel = Union(cel, Cells(R, "A"))
        End If
    Next
End With
If i Then cel.EntireRow.Delete
Set cel = Nothing
End Sub

واشعرنا بالنتيجة

 

تقبلوا تحياتي وشكري

[أبو محمد عباس]

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

الاستاذ الفاضل والعالم العلامة عبد الله باقشير

اعزكم الله ورفع قدركم واعلى مقامكم في الدنيا والاخرة

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

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

جزاكم الله خيرا وحفظكم من كل سوء

دمتم بحفظ الله ورعايته

[عبدالله باقشير]

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

جزاكم الله خيرا واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة

 

تقبلوا تحياتي وشكري

[أبو محمد عباس]

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

الاستاذ الفاضل والعالم العلامة عبد الله باقشير حفظكم الله واعطاكم الصحة والعافية

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

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

ودعواتي لكم بتمام الصحة والعافية

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

السلام عليكم

بعد اذن اخي عبد الله

قمت بمحاولة لا ادري مدى صحتها

تقوم بفتح الملف (  نتائج وشهادات سادس )  و هناك زر يقوم بنقل الناجح الى شيت مسمى Archive

حفظ.rar

تم تعديل ديسمبر 18, 2013 بواسطه أبو حنين

[أبو محمد عباس]

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

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

اشكرك جزيل الشكر والتقدير لابداء المساعدة وفقك الله ورعاك

استاذي الفاضل عند الضغط على زر الترحيل تظهر الصورة المرفقة

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

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

 

صورة الخطأ الذي يظهر.rar

 

 

[عبدالله باقشير]

السلام عليكم

الشكر واصل لاخي ابوحنين

 

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

Sub trheel()
Dim cel As Range
Dim Lr As Long, Lrr As Long, R As Long, i As Long, iCont As Long

With Sheets("البيانات")
    Lr = .Cells(Rows.Count, "B").End(xlUp).Row
    iCont = WorksheetFunction.Max(.Range("A3").Resize(Lr))
    Lrr = Cells(Rows.Count, "D").End(xlUp).Row
    For R = 3 To Lrr
        If Cells(R, "O").Value = "ناجح" Then
            i = i + 1
            .Cells(Lr + i, "A").Value = iCont + i
            .Cells(Lr + i, "B").Resize(1, 13).Value = Cells(R, "B").Resize(1, 13).Value
            .Cells(Lr + i, "O").Value = [I1]
            .Cells(Lr + i, "P").Value = [M1]
            If cel Is Nothing Then Set cel = Cells(R, "A").Resize(1, 13) Else Set cel = Union(cel, Cells(R, "A").Resize(1, 13))
        End If
    Next
End With

If i Then
    On Error Resume Next
    cel.SpecialCells(xlCellTypeConstants).ClearContents
    On Error GoTo 0
    With Range("A3:M" & Lrr)
        .Sort .Columns(4), xlAscending
    End With
End If
Set cel = Nothing
End Sub

تحياتي

[أبو محمد عباس]

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

الاستاذ والعالم العلامة عبد الله باقشير

انعم الله عليك بالصحة والعافية واغدق عليك نعمه ظاهرة وباطنة

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

واعمالكم في قمة الابداع والتميز والروعة والاتقان

زادك الله من فضله علما وشرفا

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

دمتم بحفظ الله ورعايته