تخفيف حجم شيت الكنترول

[ناصر سعيد]

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

محاوله طيبه لتخفيف حجم شيت الكنترول بكود اكثر من رائع

مجرد ان تكتب في الكود

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

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

سيتم نسخ الصف التاسع ( صف البدايه ) بمعادلاته وتنسيقاته للصفوف بعدد الطلبه فقط مهما كان عددهم والمرفق سيوضح اكثر

 

نسخ صفوف بتنسيقاتها 1.rar

[ناصر سعيد]

طريقه الاستخدام

غير عدد الطلاب الموجود في الخليه C2  وليكن 14

واضغط زر نسخ صفوف

انظر الى المسلسل في جميع الصفحات وكذلك المعادلات الموجوده في جميع الصفحات

النتيجه

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

[ناصر سعيد]

=======

الكود الرائع المستخدم

'
Sub CopyRow(sSheet As String, sRow As Long, LC As Long)
'هذا الكود للنابغه ياسر خليل
'الهدف من الكود نسخ صف بتنسيقاته ومعادلاته الى صفوف اخرى  بالعدد
'=*=*==*=*=*=*=*=*=*=*

'إلغاء تحديث الشاشة
' (الغاء مشاهدة تنفيذ الماكرو)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    Dim ws As Worksheet
    Dim cnt As Long
    

    'سطر لتفادي حدوث خطأ في حالةأن الخلايا
        ' التي سيتم مسحها أي الخلايا الثابتة كانت فارغة
    On Error Resume Next
    
        Set ws = Sheets(sSheet)

    On Error GoTo 0

    If ws Is Nothing Then
        MsgBox "ورقة " & sSheet & " غير موجودة.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    
 '[B10] تعيين قيمة للمتغير ليساوي قيمة الخلية
  'من صفحة بيانات المدرسة
    cnt = Sheets("إدخال بيانات أساسية").Range("C2").Value

    ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, LC)).Copy
    ws.Range("A" & sRow).Resize(cnt).PasteSpecial xlPasteAll
    On Error Resume Next
    
   ' يقوم بمسح الخلايا الثابتة في النطاق المنسوخ بحيث
      ' يبقى على المعادلات والتنسيق فقط ويزيل ما دون ذلك
    ws.Range("A" & sRow).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents
    Application.CutCopyMode = False

End Sub

Sub DoIt()
    CopyRow "إدخال بيانات أساسية", 9, 20
      CopyRow " ملف الإنجاز ف 1", 9, 16
        CopyRow "تحريرى ف 1", 9, 19
          CopyRow " شيت نصف العام", 9, 19
            CopyRow "نتيجة الطلبة نصف العام", 9, 18
          CopyRow " ملف الإنجاز فصل  2", 9, 22

              CopyRow "تحريرى ف 2", 9, 15
                CopyRow "الشيت الرئيسي", 9, 189
                  CopyRow "نتيجة الطلبة أخر العام ", 9, 19
                    CopyRow "نتيجة بالمجموع أخر", 9, 30
                     CopyRow "نتيجة بالمجموع نصف", 9, 16
                       'CopyRow "نتيجة الطلبة أخر العام ", 9, 12

    Range("A1").Activate
    
    ' تحديث الشاشة
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[ناصر سعيد]

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

يوجد بالملف كود اخر اردت ان اضع الاضواء عليه لفائدته

الهدف من الكود : الوصول لاي ورقه في الشيت بسهوله

'  كود التنقل بين الاوراق
Sub ShowSheetLists()
  Application.CommandBars("Workbook tabs").ShowPopup
End Sub

 

[ناصر سعيد]

طريقه اخرى

لنسخ صف معين بكل تنسيقاته ومعادلاته

الى صفوف اخرى بالعدد المطلوب

رائعه استخدام خاصيه ال Destination

  Sheets("ادخال بيانات اساسيه").Range("a7:v7").Select
     Selection.AutoFill Destination:=Range("a7:v" & ['بيانات المدرسة'!b10] + 6)
Sheets("رصد الترم الأول").Select
    Range("a7:dd7").Select
       Selection.AutoFill Destination:=Range("a7:dd" & ['بيانات المدرسة'!b10] + 6)
 Sheets("انجاز فصل اول").Select
    Range("a7:z7").Select
       Selection.AutoFill Destination:=Range("a7:z" & ['بيانات المدرسة'!b10] + 6)
Sheets("أعمال السنة").Select
    Range("a7:z7").Select
       Selection.AutoFill Destination:=Range("a7:z" & ['بيانات المدرسة'!b10] + 6)
      Sheets("الشيت الرئيسي").Select
    Range("a7:gg7").Select
      Selection.AutoFill Destination:=Range("a7:gg" & ['بيانات المدرسة'!b10] + 6)
  Sheets("كنترول شيت").Select
  Range("a11:gg11").Select
    Selection.AutoFill Destination:=Range("a11:gg" & ['بيانات المدرسة'!b10] + 10)
    Sheets("ادخال بيانات اساسيه").Select
    Range("A4").Select
    Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 

رائعه استخدام خاصيه ال Destination

[ناصر سعيد]

=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=

خاصيه

AutoFill Destination

من الروائع

[ناصر سعيد]

هذا ملف خاص

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

بخاصيه AutoFill Destination

 

 

نسخ بطريقه الاوتو فيل.rar

[ناصر سعيد]

للرفع

[علي فاهم]

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

 

 

====

للمحترمين ياسر العربي وياسر خليل

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

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

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

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

[ابن بنها]

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