كود مفيد جدا للاستاذ ياسر

علي فاهم · أغسطس 12, 2017

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

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

 'هذا الكود للمحترم ياسر العربي
 ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب
 'وقبل النسخ يتم مسح البيانات القديمه
 'تاريخ الانشاء 30/7/2017
 'تم التعديل على الكود بواسطه المحترم ياسر خليل لوجود متطلبات جديده
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Private Sub CommandButton1_Click()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim c       As Long
    
    Set ws = Sheets("بيانات الطلبة")
    c = ws.Range("C2").Value
    
    If TextBox1.Text = ws.Range("F1") Then
        Me.Hide
        TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64
        
        Application.ScreenUpdating = False
        Application.Calculation = xlManual
        
 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل
            If ws.Range("C2") < 2 Then
                Exit Sub
            End If
            
            For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "رصد الترم الثانى", "كشف ناجح"))
                lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh))
                lc = LastOccupiedColNum(sh)
                
       'حذف البيانات الموجودة في النطاق المحدد
        sh.Range("A8").Resize(Rows.Count - 7, lc).Clear
                       
'نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين
    sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").Resize(c, lc)
            Next sh
            
            Application.Goto ws.Range("A1")
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
        Unload Me
    Else
        MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation
        TextBox1.Text = ""
        TextBox1.SetFocus
    End If
End Sub

Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedRowNum = lng
End Function

Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedColNum = lng
End Function
'==================================
Private Sub UserForm_Click()

End Sub

لايوجد له ثغره روعه

علي فاهم · أغسطس 13, 2017

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

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

 'هذا الكود للمحترم ياسر العربي
 ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب
 'وقبل النسخ يتم مسح البيانات القديمه
 'تاريخ الانشاء 30/7/2017
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Private Sub CommandButton1_Click()
    Dim sh As Worksheet, lr As Long, str As String
    If TextBox1.Text = Sheets("بيانات الطلبة").Range("F1") Then
        Me.Hide
        TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب"
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل
        If Sheets("بيانات الطلبة").Cells(2, 3) < 2 Then
            Exit Sub
        End If
        '=*=*=*=*=*=*
            'On Error Resume Next
 For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "كشف ناجح"))

            lr = sh.Range("B" & sh.Range("b10000").End(xlUp).Row).Row
            sh.Activate
            ' str المتغير دا يتم تخزين اسم العمود الاخير فيه للعمل عليه
            'يتم الذهاب الى اخر عمود بالاعتماد على الصف السادس  ويتم استخلاص اسم العمود من اسم النطاق
   str = Split(sh.Range("XFD7").End(xlToLeft).Address, "$")(1)
            'حذف البيانات الموجودة في النطاق المحدد
            sh.Range("A8:" & str & lr + 7).Clear
            '   نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين
            sh.Range("a7:" & str & 7).AutoFill Destination:=Range("a7:" & str & [    'بيانات الطلبة'!C2] + 6)
        Next
      Sheets("بيانات الطلبة").Select
    Range("A4").Select

        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Unload Me
    Else
        MsgBox "عفوا كلمة المرور خاطئة و لن يتم تنفيذ المطلوب"
        TextBox1.Text = ""
        TextBox1.SetFocus
    End If
End Sub

Private Sub Label1_Click()

End Sub

Private Sub UserForm_Click()

End Sub

اي الكودين .. بعد اذنكم وشكرا مقدما لحضراتكم

ياسر خليل أبو البراء · أغسطس 13, 2017

إذا كنت لا تريد المسح قم بإزالة هذا السطر فقط

sh.Range("A8:" & str & lr + 7).Clear

أما إذا كان المطلوب غير ذلك فيرجى إرفاق ملف موضحاً فيه شكل النتائج المتوقعة

علي فاهم · أغسطس 13, 2017

الاستاذ ياسر

شكر ا جزيلا لك

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

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

هايكون للطالب المحول الينا .. لازم يوضع اسمه في اخر الصفوف

نسخ صفوف بعد الصفوف الموجوده.rar

علي فاهم · أغسطس 13, 2017

مثال عدد طلاب الصف الدراسي 200 طالب

ضغطنا الزر فنسخ صفوف بعدد 200 .. بعد اسبوع جاء الي المدرسه طالب محول .. مطلوب اضافته للمدرسه فيكون عدد طلاب المدرسه 201

الطالب المحول + الطلاب المنقولون

علي فاهم · أغسطس 14, 2017

للرفع

علي فاهم · أغسطس 14, 2017

شكرا مقدما

علي فاهم · أغسطس 14, 2017

في ١٣‏/٨‏/٢٠١٧ at 05:55, ياسر خليل أبو البراء said:
إذا كنت لا تريد المسح قم بإزالة هذا السطر فقط
sh.Range("A8:" & str & lr + 7).Clear
أما إذا كان المطلوب غير ذلك فيرجى إرفاق ملف موضحاً فيه شكل النتائج المتوقعة

ويتبقى سطر بدايه نسخ الصفوف مختلف .. ممكن ينسخ بعد 100 صف او ينسخ بعد 200 صف

نرجو الحل لو سمحت

علي فاهم · أغسطس 15, 2017

للرفع لافذاذ المنتدى

**قصي** · أغسطس 15, 2017

الى ملك الاكواد استاذ ياسر

حلها يابطل

ياسر خليل أبو البراء · أغسطس 15, 2017

ليس لدي فكرة عن المطلوب ولو كان لدي ما ترددت في المشاركة .. ربما يفهم غيري المطلوب ويشارك في الموضوع إن شاء الله

**قصي** · أغسطس 15, 2017

الكود الاول الذي تفضل به استاذ ياسر العربي وتكرم استاذ ياسر خليل باضافه فيه ليتناسب والمطلوب .. ماذا يفعل ؟

يمسح كل بيانات الصفحات ابتداء من الصف التاني بعد الترويسه .. تمام

الكود الذي يطلبه المعلمون الان

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

لاننا سنحافظ عليها

وهي بيانات الطلاب ..

بعد مده من الزمان سياتي طالب محول

المطلوب اضافه صف او العدد الجديد من الصفوف تحت الصفوف الموجوده

ولايمسح اي بيانات سابقه .. ادعو الله ان اكون وفقت في شرح المطلوب

ياسر خليل أبو البراء · أغسطس 15, 2017

إذاً في الكود الموجود يتم مسح السطر المسئول عن المسح .. حيث يقوم بعملية النسخ بشكل طبيعي أي يتم حذف سطر المسح فقط (هذا حسب ما فهمت من كلامك) ، ويمكنك التجربة ومشاهدة النتائج .. وإذا لم تكن النتائج هي المطلوبة ضع صورة لشكل النتائج المتوقعة ليسهل فهم المطلوب ..

**قصي** · أغسطس 15, 2017

سيتم التجربه .. جزيت خيرا

**قصي** · أغسطس 16, 2017

استاذ ياسر

حتى تزداد الرؤيه

وضعت عدد الطلاب 5 ونفذت الكود الاول نسخ 5 صفوف .. تمام

كتبت بعد ذلك عدد الطلاب المحولين 2 ونفذت الكود التاني بعد ازاله المسح

ماذا حدث .. ظلت اعداد الصفوف 5 ولم تزد ليه لانه تم النسخ من الصف الذي يلي العناوين

المفروض كان العدد يبقى 7

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

ياسر خليل أبو البراء · أغسطس 16, 2017

هلا أرفقت آخر نسخة من الملف والكود ومطبق فيه ما قمت بعمله .. وما هي الخلية المرتبطة بعدد صفوف النسخ لأني أنسى الموضوعات ، وربما لا أتذكر .. فذكرني بتفاصيل الملف مرة أخرى .. وما هي أوراق العمل المطلوب العمل عليها وما هي أوراق العمل المطلوب استثنائها ؟

علي فاهم · أغسطس 16, 2017

بعد اذنك اخي قصي

هذا هو الملف

به زر اصفر به الكود المعدل من طرفك اخي استاذ ياسر

ويعمل جيدا

الزر الاخر لايعمل

اكتب في Q1 الرقم 2 واضغط الزر المفروض يزيد صفين لايحدث ذلك

نسخ صفوف بعد الصفوف الموجوده.rar

ياسر خليل أبو البراء · أغسطس 16, 2017

جربوا الكود التالي عله يفي بالغرض

Private Sub CommandButton1_Click()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim c       As Long

    Set ws = Sheets("بيانات الطلبة")
    c = ws.Range("Q1").Value

    If TextBox1.Text = ws.Range("F1") Then
        Me.Hide: TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64

        Application.ScreenUpdating = False
        Application.Calculation = xlManual
            If ws.Range("Q1") < 2 Then Exit Sub
    
            For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف ناجح", "الحاله", "كنترول شيت", "رصد الترم الثانى", "كنترول شيت (2)", "رصد الترم الأول", "كشف الدور الثاني"))
                lr = IIf(LastRowColumn(sh, "R") = 9, 9, LastRowColumn(sh, "R"))
                lc = LastRowColumn(sh, "C")
                sh.Range("A" & lr).Resize(1, lc).AutoFill Destination:=sh.Range("A" & lr).Resize(c + 1, lc)
            Next sh
            
            Application.Goto ws.Range("A1")
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
        
        Unload Me
    Else
        MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation
        TextBox1.Text = ""
        TextBox1.SetFocus
    End If
End Sub

Function LastRowColumn(ws As Worksheet, rc As String) As Long
    Dim lng As Long

    If Application.WorksheetFunction.CountA(ws.Cells) <> 0 Then
        With ws
            If UCase(rc) = "R" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
            ElseIf UCase(rc) = "C" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
            End If
        End With
    Else
        lng = 1
    End If

    LastRowColumn = lng
End Function

علي فاهم · أغسطس 16, 2017

تمام .. مش لاقي كلمه حلوة افضل من جزاك الله خيرا

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

نسخ صفوف واضافه طالب .rar

تم تعديل أغسطس 16, 2017 بواسطه علي فاهم

ياسر خليل أبو البراء · أغسطس 16, 2017

وجزيت خيراً بمثل ما دعوت لي أخي الكريم

والحمد لله أن تم المطلوب على خير

**قصي** · أغسطس 17, 2017

استاذ ياسر

اشكرك وادعو الله ان يجزيك خيرا

الحل متميز

=======

عندي سؤال

نحن ناخد الصف الذي يلي العنوان وننسخ زيه

هل يمكن ان يكون هذا الصف فوق مثلا الصف الاول دائما ونخفي هذا الصف

لماذا ؟

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

والراي لكم في فكره حل

استاذ ياسر

اشكرك وادعو الله ان يجزيك خيرا

الحل متميز

=======

عندي سؤال

نحن ناخد الصف الذي يلي العنوان وننسخ زيه

هل يمكن ان يكون هذا الصف فوق مثلا الصف الاول دائما ونخفي هذا الصف

لماذا ؟

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

والراي لكم في فكره حل

استاذ ياسر

اشكرك وادعو الله ان يجزيك خيرا

الحل متميز

=======

عندي سؤال

نحن ناخد الصف الذي يلي العنوان وننسخ زيه

هل يمكن ان يكون هذا الصف فوق مثلا الصف الاول دائما ونخفي هذا الصف

لماذا ؟

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

والراي لكم في فكره حل

علي فاهم · أغسطس 17, 2017

في ١٣‏/٨‏/٢٠١٧ at 00:59, علي فاهم said:

sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").Resize(c, lc)

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

ياسر خليل أبو البراء · أغسطس 17, 2017

جرب إضافة السطرين التاليين

                On Error Resume Next
                sh.Range("A" & lr + 1).Resize(c, lc).SpecialCells(xlCellTypeConstants).ClearContents

بعد هذا السطر في الكود

sh.Range("A" & lr).Resize(1, lc).AutoFill Destination:=sh.Range("A" & lr).Resize(c + 1, lc)

علي فاهم · أغسطس 17, 2017

روعه اضافه صف اوصفوف بعد بيانات الطلاب للاستاذ ياسر خليل

Private Sub CommandButton1_Click()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim c       As Long

    Set ws = Sheets("بيانات الطلبة")
    c = ws.Range("Q1").Value

    If TextBox1.Text = ws.Range("F1") Then
        Me.Hide: TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64

        Application.ScreenUpdating = False
        Application.Calculation = xlManual
            If ws.Range("Q1") < 1 Then Exit Sub
    
            For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف ناجح", "الحاله", "كنترول شيت", "رصد الترم الثانى", "كنترول شيت (2)", "رصد الترم الأول", "كشف الدور الثاني"))
                lr = IIf(LastRowColumn(sh, "R") = 9, 9, LastRowColumn(sh, "R"))
                lc = LastRowColumn(sh, "C")
  sh.Range("A" & lr).Resize(1, lc).AutoFill Destination:=sh.Range("A" & lr).Resize(c + 1, lc)
    On Error Resume Next
  sh.Range("A" & lr + 1).Resize(c, lc).SpecialCells(xlCellTypeConstants).ClearContents
            Next sh
            
            Application.Goto ws.Range("A1")
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
        
        Unload Me
    Else
        MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation
        TextBox1.Text = ""
        TextBox1.SetFocus
    End If
End Sub

Function LastRowColumn(ws As Worksheet, rc As String) As Long
    Dim lng As Long

    If Application.WorksheetFunction.CountA(ws.Cells) <> 0 Then
        With ws
            If UCase(rc) = "R" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
            ElseIf UCase(rc) = "C" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
            End If
        End With
    Else
        lng = 1
    End If

    LastRowColumn = lng
End Function

Private Sub UserForm_Click()

End Sub

لو شويه شرح في الكود لان فيه جديد علينا

ياسر خليل أبو البراء · أغسطس 17, 2017

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

أو قم بدراسة الكود واسأل فقط عن سطر أو أكثر من الكود لأن الكود يحتاج فيما لا يقل عن ساعتين لشرحه بشكل كامل .. وهذا غير متوفر

تسجيل الدخول

كود مفيد جدا للاستاذ ياسر

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information