مسح صفوف في اوراق مختلفه مره واحده

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

أخي الكريم ناصر

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

معظم من يرتاد الموقع يريد أن يقضي طلبه وفقط ولا يريد التعلم ... والله المستعان

ومن يريد التعلم سيبحث هنا وهناك وفي كل مكان حتى يصل للمعلومة .. وكما أخبرتك ما جاء سهلاً سيذهب سدىً

**ناصر سعيد** · أغسطس 7, 2017

نريد احد الكرام

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

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

الكود مشروح في الأساس من قبل أخونا ياسر العربي .. والإضافات في الكود بسيطة ولا تحتاج لشرح حيث تم الاستعانة بدالة معرفة لمعرفة آخر صف مستخدم في ورقة العمل ، ودالة أخرى لمعرفة آخر عمود مستخدم في ورقة العمل .. وعلى أساس معرفة رقم آخر صف وآخر عمود يتم المسح والنسخ ..

**ناصر سعيد** · أغسطس 7, 2017

جزاك الله خيرا .. جاري تضييط الملف النهائي ليكون مرجعا لمن اراده

**ناصر سعيد** · أغسطس 8, 2017

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

من ملف بسهوله ويس وذلك

بعد مسح البيانات القديمه

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

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

نسخ 1صفوف.rar

وهذا هو الكود المرفق بالملفلمن اراد الاستمتاع بالكنوز

 
 'هذا الكود للمحترم ياسر العربي
 ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب
 'وقبل النسخ يتم مسح البيانات القديمه
 'تاريخ الانشاء 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

4 دقائق مضت, ناصر سعيد said:

lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh)) lc = LastOccupiedColNum(sh)

نريد شرح لهم من فضلكم

**ناصر سعيد** · أغسطس 9, 2017

للرفع رفع الله مقداركم

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

تحديد رقم آخر صف فإذا كان يساوي 7 تظل قيمة آخر صف 7 أما خلاف ذلك فيجلب رقم آخر صف ..

علي فاهم · أغسطس 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

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

**ناصر سعيد** · أغسطس 24, 2017

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

ويرحم امواتنا

الكود مهم جدا لرجال التربيه والتعليم ( الكنترولات ) لتخفيف حجم البرنامج ليعمل على عدد الطلاب فقط مهما كان عددهم

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

'==================

Option Explicit
'هذا الكود للمحترم ياسر خليل
' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه
'يعمل الكود بعد مسح بيانات الطلاب القديمه
'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده
'تم هذا الكود في   22/8/2017

Sub Test_CopyRow_Procedure()

       'أمثلة لكيفية استخدام الإجراء الفرعي
  CopyRow "بيانات الطلبة", 9
    CopyRow "رصد الترم الثانى", 10
    CopyRow "كنترول شيت", 10
    CopyRow "الحاله", 11
    CopyRow "كشف ناجح", 9
    CopyRow "أعمال السنة", 7
    CopyRow "تحريرى ف 2", 7
    CopyRow "إنجاز1", 7
    CopyRow "بيانات الطلبة", 9
    CopyRow "تحريرى ف 1", 7
    CopyRow "كشف الدور الثاني", 9
  CopyRow "رصد الترم الأول", 10
 CopyRow "كنترول شيت (2)", 11

'استعادة خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    Application.Goto Sheets("بيانات الطلبة").Range("A1")
End Sub

Sub CopyRow(sSheet As String, sRow As Long)
    Dim ws      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim i       As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    'جملة لتجنب حدوث خطأ عند تعيين ورقة العمل
    On Error Resume Next
    
        Set ws = Sheets(sSheet)
        
      'جملة لاستعادة خاصية تتبع الأخطاء
    On Error GoTo 0

    'إذا لم تكن هناك ورقة عمل بهذا الاسم
    If ws Is Nothing Then
    
 'تظهر رسالة تفيد بذلك ثم يتم الخروج من الإجراء الفرعي
        MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    'مسح الصفوف
    ws.Rows(sRow + 1).Resize(1000).Clear
    
       'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل
    i = Sheets("بيانات الطلبة").Range("Q1").Value - 1
    lc = LastRowColumn(ws, "C")
    
   'تحديد رقم آخر صف بورقة العمل المعنية مضافاً إليها 1 ليبدأ من أول صف جديد
    lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    
    On Error Resume Next
    
    
    ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy
    
        'لصق البيانات التي تم نسخها بداية من أول صف فارغ وبامتداد عدد الصفوف المقررة
    ws.Range("A" & lr).Resize(i).PasteSpecial xlPasteAll
    
          'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه
    ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents

   'سطر للذهاب لأول خلية في ورقة العمل بعد القيام بعملية النسخ
    Application.Goto ws.Range("A1")
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

وهذا هو المرفق
attach نسـخ صفوف في صفحات مختلفه 1.rar

نسـخ صفوف في صفحات مختلفه 1.rar

**ناصر سعيد** · أغسطس 25, 2017

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

نسـخ صفوف في صفحات مختلفه 11.rar

==================================

Option Explicit
'هذا الكود للمحترم ياسر خليل
' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه
'يعمل الكود بدون مسح بيانات الطلاب القديمه
'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده
'تم هذا الكود في   25/8/2017

Sub CopyRow_Procedure()
    CopyRow "بيانات الطلبة", 9
    CopyRow "رصد الترم الثانى", 10
    CopyRow "كنترول شيت", 10
    CopyRow "الحاله", 11
    CopyRow "كشف ناجح", 9
    CopyRow "أعمال السنة", 7
    CopyRow "تحريرى ف 2", 7
    CopyRow "إنجاز1", 7
    CopyRow "تحريرى ف 1", 7
    CopyRow "كشف الدور الثاني", 9
    CopyRow "رصد الترم الأول", 10
    CopyRow "كنترول شيت (2)", 11

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    Application.Goto Sheets("بيانات الطلبة").Range("A1")
End Sub

Sub CopyRow(sSheet As String, sRow As Long)
    Dim ws      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim i       As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    On Error Resume Next
        Set ws = Sheets(sSheet)
        If ws Is Nothing Then
            MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!"
            Exit Sub
        End If
    On Error GoTo 0

    i = Sheets("بيانات الطلبة").Range("Q1").Value - 1
    lc = LastRowColumn(ws, "C")
    lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

    On Error GoTo Skipper
    ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy
    ws.Range("A" & lr).Resize(i + 1).PasteSpecial xlPasteAll
    ws.Range("A" & lr).Resize(i + 1, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents
Skipper:
    Application.Goto ws.Range("A1")
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

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

نسـخ صفوف في صفحات مختلفه 11.rar

تسجيل الدخول

مسح صفوف في اوراق مختلفه مره واحده

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

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

ناصر سعيد

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

ناصر سعيد

ناصر سعيد

ناصر سعيد

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

علي فاهم

ناصر سعيد

ناصر سعيد

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information