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

السلام عليكم أخي الكريم

بدايةً أهلاً بك في المنتدى ونورت بين إخوانك

ثانياً عند طرح موضوع يجب إرفاق الملف في المنتدى وليس على رابط خارجي

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

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

المهم قم بوضع الكود التالي في حدث الفورم وجرب بنفسك 

Private Sub CommandButton1_Click()
    Dim ws      As Worksheet
    Dim xf      As Variant
    Dim lr      As Integer

    Set ws = Sheets("ss")
    If Me.TextBox1.Value = "" Then MsgBox "Please Enter Name": Exit Sub
    If Me.TextBox2.Value = "" Then MsgBox "Please Enter Salary": Exit Sub
    If Me.ComboBox1.Value = "" Then MsgBox "Please Enter Statement": Exit Sub

    xf = Application.Match(ComboBox1.Value, ws.Rows(1), 0)

    If IsNumeric(xf) Then
        lr = ws.Cells(21, xf).End(xlUp).Row
        If lr = 2 Then MsgBox "This Is The Last Row", vbExclamation: Exit Sub

        ws.Cells(lr + 1, xf).Value = TextBox1.Value
        ws.Cells(lr + 1, xf + 1).Value = TextBox2.Value
        
        Call Reset_UserForm_Controls
    End If
End Sub

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Sub Reset_UserForm_Controls()
    Dim c       As Control

    For Each c In Me.Controls
        Select Case TypeName(c)
            Case "TextBox"
                c.Text = vbNullString
            Case "ListBox", "ComboBox"
                c.ListIndex = -1
        End Select
    Next c
    TextBox1.SetFocus
End Sub

حاول مرة أخرى فالرسالة معناها ذلك .. ولا يوجد احتمال آخر

وعليكم السلام

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

Sub Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim arr         As Variant
    Dim temp        As Variant
    Dim x           As Variant
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    
    Set ws = Sheets("البيانات")
    Set sh = Sheets("الخلاصة")
    arr = sh.Range("A2:A" & sh.Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim temp(1 To UBound(arr, 1), 1 To 1)
    k = -1
    
    Application.ScreenUpdating = False
        For i = LBound(arr, 1) To UBound(arr, 1)
            k = k + 1
            x = Application.Match(CStr(arr(i, 1)), ws.Columns(8), 0)
            If IsNumeric(x) Then
                For j = 18 To 29
                    If ws.Cells(i, 18) = "" Then GoTo Skipper
                    If ws.Cells(i, j) = "" Then temp(k, 1) = ws.Cells(i, j - 1): GoTo Skipper
                Next j
            Else
                temp(k, 1) = ""
            End If
Skipper:
        Next i
    
        sh.Range("E2").Resize(k, UBound(temp, 2)).Value = temp
    Application.ScreenUpdating = True
End Sub

وعليكم السلام أخي الكريم

بالنسبة للاسم "أبو الحارث - أقساط" آخر تاريخ هو في الدفعة السادسة بتاريخ 08/10/2017 لكن في النتائج المتوقعة التاريخ المسجل هو "11/05/2017" ... !!

البداية للنسخ هو آخر صف حيث يتم عمل تعبئة تلقائية لآخر صف ... ولمدى عدد الصفوف المطلوبة طبقاُ للمتغير c الذي يشير للخلية Q1

استبدل الفاصلة العادية بفاصلة منقوطة .. يرجع لإعدادات الويندوز لديك ..

بارك الله فيك أخي العزيز مهند ومشكور على كلماتك الطيبة ودعائك الطيب .. تقبل وافر تقديري واحترامي

تستخدم IIF لاختبار شرط زي IF لكن مختصرة في شرط واحد .. لو تحقق يعمل كذا ولو لم يتحقق يعمل كذا ..

بالنسبة للدالة المعرفة تقوم بمعرفة رقم آخر صف أو رقم آخر عمود .. حيث قمت بدمج الدالتين المعرفتين في دالة معرفة واحدة .. فإذا أردت معرفة رقم الصف تكتب في البارامتر الثاني حرف الـ R ، وإذا أردت معرفة رقم آخر عمود تكتب الحرف C
المهم في السطر الكود بيشوف رقم آخر صف فلو كان رقم آخر صف يساوي 9 .. إذاً المتغير المسمى lr هيساوي 9

أما إذا كان لا يساوي 9 يتحقق الجزء الثاني من الشرط حيث تقوم الدالة المعرفة باحتساب رقم آخر صف

والمتغير sh يشير لورقة العمل المطلوب استخراج رقم آخر صف منها ، وهذا المتغير بدوره متغير لأنه يعمل على مصفوفة من أوراق العمل

أرجو أن تكون الصورة قد اتضحت الآن

بارك الله فيك أخي سمير ومشكور على كلماتك الطيبة

أخي محمود

حاول طرح موضوع لكل طلب .. بحيث تجد استجابة أفضل ..

غالباً لا تجد المشاركة الأفضل في المشاركات الفرعية .. 

وجزيت خيراً .. أي تحميل جاري !!

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

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

وعليكم السلام أخي الكريم سمير

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

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

                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)

لا الكود صحيح بهذا الشكل ..ما قصدته استخدام كلمة Copy في الأكواد والتي يلزمها تفريغ الذاكرة بهذا السطر

Application.CutCopyMode=False

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

Sub Rename_UserForm()
    ActiveWorkbook.VBProject.VBComponents("UserForm1").Name = "ufTest"
End Sub

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

ما هي إمكانيات الجهاز التي تعمل عليه؟ قد تكون المشكلة في الجهاز ..

وعليكم السلام أخي الكريم سمير

ما الغرض من ذلك الأمر ..؟

بارك الله فيك أخي الكريم محمود .. هو دا الشغل لازم تشارك بإيجابية لكي تتعلم .. الله ينور

لمزيد حول الموضوع اطلع على الرابط التالي ..

http://yasserkhalilexcellover.blogspot.com.eg/2016/04/toggles-not.html

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

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

أخي الكريم عمرو رجب 

أهلاً بك في المنتدى ... يرجى طرح موضوع جديد مكتمل الأركان موضحاً التفاصيل ومرفقاً لملف به بعض البيانات وبعض النتائج المتوقعة لتجد استجابة أفضل

حاول تلغي الخلايا المدمجة الموجودة في الملف .. بشكل نهائي دي أول خطوة

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

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

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