اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


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

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

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

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

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

 

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

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

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

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

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

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

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

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

 

نسخ 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)

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

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

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

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


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

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

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

  • 2 weeks later...

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

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

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

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

'==================
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

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

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

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information