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

كما ذكرت لك ركز على الأساسيات والبدايات والأولويات التي تساعدك بشكل كبير ، وبشكل تتمكن منه من تطبيق الحلول المقدمة لك وفقك الله لما يحب ويرضى تقبل وافر تقديري واحترامي

أخي الكريم وعليكم السلام قم بالإطلاع على الرابط التالي علك تجد مبتغاك الرابط من هنا

ما الفائدة من تلك الحيلة ؟ إذا عرف السبب بطل العجب

شيل علامة الصح يا كبير

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

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

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

أخي الكريم جرب مرة أخرى لقد جربت الكود عدة مرات بالأمس ويعمل بشكل جيد جداً ولا مشكلة فيه .. حيث يتم أولاً حذف الصفوف كلها تحت الصف الرئيسي الذي تقوم بالنسخ منه وحتى نهاية الصفوف التي بها حدود .. ثم يتم التعامل مع بقية الأسطر بالشكل الطبيعي وهذه هي الأسطر التي أضيفت .. Set rngEnd = Range(Mid(Ws.UsedRange.Address, InStr(1, Ws.UsedRange.Address, ":") + 1)) lngRow = rngEnd.Row - 4 Ws.Rows(sRow + 1 & ":" & lngRow).Delete .Rows(sRow + 2).Resize(cnt + 1).Insert

أخي الكريم وائل شعبان وعليكم السلام ورحمة الله وبركاته صراحة موضوع التعلم موضوع صعب لا شك في ذلك ، وليست الصعوبة في صعوبة المادة التي ستتعلمها إنما في التجلد والصبر على التعلم ، فكم رأيت من أناس كانت لديهم الحماسة والدافيعة للتعلم وتوقفوا ولم يكملوا المسيرة .. التعلم لن يصل بك إلى شاطيء أو بر .. ستظل في محيط العلم طالما حييت ، فأنا عن نفسي منذ تعلمت الإكسيل وتوغلت فيه أجد كل يوم معلومة جديدة وأسلوب جديد ، وهذا ما يجعل هذا المجال ممتع ، إذ أنه لا حدود للعلم ، وكما تعرف أنه منهومان لا يشبعان طالب علم وطالب مال .. ما أقصده من كلامي أنك لن تصل إلى نهاية لهذا العلم ، أعرف أنك تريد أن تتعلم بما يكفي لخدمة الغرض النبيل الذي تسعى من أجله ..وفقك الله لما يحب ويرضى ، وإن شاء الله ستجد المساعدة والمساندة من إخوانك .. ولتركز على الأساسيات دون الفروع حتى لا تتشتت ويضيع جهدك هباءً .. تقبل وافر تقديري واحترامي

أخي الكريم لم أطلع على الملف في الحقيقة لضيق وقتي .. ولكن بإلقاء نظرة سريعة على الكود أجد أنه في الحلقة التكرارية لجأت إلى الأسلوب التسلسلي من 1 إلى 20 .. وللعلم عند الحذف يجب أن يتم عكس الحلقة لتتم بشكل منضبط أي أن الحلقة يجب أن تبدأ من 20 إلى 1 ثم تضيف كلمة Step -1 لتتناقص أثناء التكرار .. أرجو أن يفيد ردي في حل الإشكال تقبل تحياتي

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

جرب المعادلة التالية أخي الكريم =LOOKUP(B7,$O$4:$P$9,$N$4:$N$9) عفواً لم أنتبه لمشاركتك .. ما المشكلة في المعادلة طالما أنها تؤدي الغرض ، فهي فعالة وعملية في حالتك هذه تقبل تحياتي

استبدل الكود الموجود في الموديول بهذا الكود الجديد بعد إضافة أسطر لتؤدي المطلوب الأخير Sub CopyRow(sSheet As String, sRow As Long, LC As Long) Dim Ws As Worksheet Dim cnt As Long Dim rngEnd As Range Dim lngRow As Long On Error Resume Next Set Ws = Sheets(sSheet) On Error GoTo 0 If Ws Is Nothing Then MsgBox "Sheet " & sSheet & " Doesn't Exist In The Workbook.", vbExclamation, "Sheet Not Found!" Exit Sub End If cnt = Sheets("بيانات المدرسة").Range("B10").Value With Ws Set rngEnd = Range(Mid(Ws.UsedRange.Address, InStr(1, Ws.UsedRange.Address, ":") + 1)) lngRow = rngEnd.Row - 4 Ws.Rows(sRow + 1 & ":" & lngRow).Delete .Rows(sRow + 2).Resize(cnt + 1).Insert .Range(Ws.Cells(sRow, 1), .Cells(sRow, LC)).Copy .Range("A" & sRow).Resize(cnt + 1).PasteSpecial xlPasteAll On Error Resume Next .Range("A" & sRow + 1).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents End With Application.CutCopyMode = False End Sub Sub DoIt() CopyRow "بيانات الطلبة", 7, 19 CopyRow "إنجاز1", 7, 15 CopyRow "رصد الترم الأول", 7, 29 CopyRow "أعمال السنة", 7, 15 CopyRow "رصد الترم الثانى", 7, 102 CopyRow "كنترول شيت", 12, 114 End Sub

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

أخي الكريم ناصر الأفضل أن تتبع الخطوات بشكل صحيح ... قم بحذف الأكواد الموجودة في موديول رقم 1 وضع هذه الأكواد مكانها Sub CopyRow(sSheet As String, sRow As Long, LC As Long) 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 "Sheet " & sSheet & " Doesn't Exist In The Workbook.", vbExclamation, "Sheet Not Found!" Exit Sub End If cnt = Sheets("بيانات المدرسة").Range("B10").Value Ws.Range(Ws.Cells(sRow, 1), Ws.Cells(sRow, LC)).Copy Ws.Range("A" & sRow).Resize(cnt + 1).PasteSpecial xlPasteAll On Error Resume Next Ws.Range("A" & sRow + 1).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents Application.CutCopyMode = False End Sub Sub DoIt() CopyRow "بيانات الطلبة", 7, 19 CopyRow "إنجاز1", 7, 15 CopyRow "رصد الترم الأول", 7, 29 CopyRow "أعمال السنة", 7, 15 CopyRow "رصد الترم الثانى", 7, 102 CopyRow "كنترول شيت", 12, 114 End Sub ثم في حدث الفورم احذف الأكواد الموجودة وضع هذه الأكواد مكانها Private Sub CommandButton1_Click() If TextBox1.Text = Sheets("بيانات الطلبة").Range("Z1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب" Application.ScreenUpdating = False Call DoIt Application.ScreenUpdating = True Unload Me Else MsgBox "عفوا كلمة المرور خاطئة و لن يتم تنفيذ المطلوب" TextBox1.Text = "" TextBox1.SetFocus End If End Sub بخصوص أنني أستاذ كبير فقولي كما هو أنني مجرد متعلم وباحث ، وهذا ليس تواضع بل هي الحقيقة وعليك ان تتأكد من ذلك الأمر تقبل تحياتي

أخي الكريم ناصر ما الموقف الذي وضعتك فيه؟؟ أنا لا أقصد الإهانة ... وأنا لست بأستاذ كبير إنما أنا متعلم يسعى للتعلم ................................ الأفضل أن ترفق ملفك الذي به آخر كود .. أو قم بنسخ الكود مرة أخرى بشكل صحيح ...

كود بلا ملف مرفق زي السلطة من غير طماطم .. مع تحياتي

الرسالة واضحة جداً ضع جملة End Sub .. وذلك بعد السطر Application.ScreenUpdating=True أي قبل الإجراء الفرعي الذي يبدأ بكلمة Sub CopyRow الخطأ من عندك أخي الفاضل .. ركز الله يبارك فيك

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

وعليكم السلام ورحمة الله وبركاته أخي الحبيب محي الدين إليك حل مشكلتك في الرابط التالي لنفس الموضوع ، تمت إضافة كود في نهاية الموضوع يلبي طلبك إن شاء الله الرابط من هنا

أخي الكريم عبد الله فاروق .. هل اتحلت المشكلة أم لا؟ قم بتنصيب أكروبات النسخة البروفيشنال وإن شاء الله يعمل معك الملف بشكل جيد تقبل تحياتي

أخي الكريم محي الدين ولكن الأمر سيطالب بحفظ المصنفات المفتوحة إذا حدث تغيير ويغلق المصنفات دون إغلاق التطبيق

وجزيت خيراً أخي الكريم أكرم بمثل ما دعوت لي والحمد لله أن تم المطلوب على خير

أخي الكريم هل أدى حل الأخ سليم الغرض أم لا؟ أم أنك تريد الحل بالأكواد؟؟ يرجى مزيد من التوضيح ... أم أن مقصدك عملية تجميع للبيانات من الأعمدة المجاورة للعمود الأول ؟؟

بصراحة الموضوع غريب نوعاً ما ..كيف يمكن لمصنف أن يحوي كل هذه الأنماط ؟؟ كيف تم التعديل على الملف الأصلي؟