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

السلام عليكم أخي الكريم بدايةً أهلاً بك في المنتدى ونورت بين إخوانك ثانياً عند طرح موضوع يجب إرفاق الملف في المنتدى وليس على رابط خارجي ثالثاُ الملف المرفق في الرابط الخارجي ملف محبط واعذرني لصراحتي .. حيث وجدت حجم الملف كبير جداً حوالي (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