أبو حنــــين

و الله اخي يوسف الكود يعمل عندي بطريقة عادية و لا اعلم اين الخلل عندك و هذا شرح الكود سطرا سطرا Private Sub CommandButton1_Click() آخر_خلية = ورقة1.Range("IV1").End(xlToLeft).Column ' هذ السطر يحدد آخر خلية افقيا تحتوي على بيانات '------------------------------------------------------------------------------------------ Na = Frame1.Controls("textbox" & 2).Text ' هو النص المكتوب في مربع التص رقم 2 : Na '------------------------------------------------------------------------------------------ RR = MsgBox(" انت على وشك حذف السيد : " & Na & " هل تريد المتابعة ؟ ", vbCritical + vbYesNo + vbMsgBoxRight, "") ' رسالة تأكيد الحذف '------------------------------------------------------------------------------------------ If RR = vbYes Then ' اذا كان الرد بنعم '------------------------------------------------------------------------------------------ Rows(ActiveCell).Offset(1, 0).Delete Shift:=xlUp ' احذف الصف الموافق للخلبة النشطة '------------------------------------------------------------------------------------------ End If ' نهاية الشرط '------------------------------------------------------------------------------------------ آخر_صف_مكتوب = ورقة1.Cells(Rows.Count, "A").End(xlUp).Row - 1 ' هذا السطر يحدد آخ خلية عموديا تحتوي على بيانات '------------------------------------------------------------------------------------------ For q = 1 To آخر_صف_مكتوب ' متغير من اول خلية الى آخر خلية مكتوبة '------------------------------------------------------------------------------------------ ورقة1.Cells(q + 1, 1) = q ' أعد ترتيب العمود الاول تصاعديا اي 1 ’ 2 ’ 3 ’ .... Next End Sub

أخي يوسف لقد جربت الملف و هو يعمل عندي بطريقة عادية ارجو ان تقوم بالتالي لتتأكد ـ 1 شغل البرنامج ـ 2 قبل الحذف أظهر المستند بالضغط على : المستند ـ 3 عند ظهور المستند ستجد الترتيب رقم 7 بلون ازرق و يحمل الحرف A فوق الحرف A هناك الحرفان B و B و تحت الترتيب 7 هناك الحرف C و C ـ قم بالضغط مرتين على اي خلية لظهور الفورم ثم قم بحذف الترتيب 7 اي اين يوجد الحرف A سيحذف الحرف A و تبقى الحروف BB و CC و كل هذا من اجل التأكد فقط قمت بالتجربة مرات و مرات و النتائج صحيحة ربما انني قد فقدت التركيز و الله اعلم ارجو ان تعيد التجربة مع الملف المرفق الآن في هذه المشاركة ملاحظة : لقد اوقفت اخفاء الملف عند الضغط مرتين على اي خلية و ذلك للتأكد من الحذف 2.rar

وجدت بعض الاخطاء و تم تصحيحها بحول الله و سبحان الذي لا يسهى و لا ينسى 1.rar

أخي الحبيب : / يوسف هل غيرت كود الحذف كما في المشاركة 30

نعم أخي غير امسح الكود السابق كليا و غيره بهذا الكود Private Sub Worksheet_Selectionchange(ByVal Target As Range) For t = 5 To 71: For s = 1 To 6 If Target.Column = 3 Then If Cells(t, 3).Value = Target.Value Then Cells(t, s).Interior.ColorIndex = Cells(t, 3).Value + 32 Else Cells(t, s).Interior.ColorIndex = 0 End If: End If: Next: Next End Sub

بالفعل كان هناك خطأ بحيث يحذف الصف ما قبل الحالي و ها هو التعديل غير زر كود الحذف بهذا الكود Private Sub CommandButton4_Click() آخر_خلية = ورقة1.Range("IV1").End(xlToLeft).Column Na = Frame1.Controls("textbox" & 2).Text RR = MsgBox(" انت على وشك حذف السيد : " & Na & " هل تريد المتابعة ؟ ", vbCritical + vbYesNo + vbMsgBoxRight, "") If RR = vbYes Then Rows(ActiveCell).Offset(1, 0).Delete Shift:=xlUp End If آخر_صف_مكتوب = ورقة1.Cells(Rows.Count, "A").End(xlUp).Row For q = 1 To آخر_صف_مكتوب ورقة1.Cells(q + 1, 1) = q: Next End Sub

أخي جمال رغم انني لم استطع تحميل الملف بسبب بطئ النت لكن يبدو انه عمل جبار حسب رأي الاخوة الكرام جزاك الله كل الخير و جعله في ميزان حسناتك

اخي الحبيب فهد جرب الملف و اخبرني بالنقائص او الاخطاء ليتم تفاديها ان شاء الله

غير الكود السابق بالكود التالي Private Sub Workbook_Open() For s = 1 To ThisWorkbook.Sheets.Count If Sheets(s).Name < Val(Format(Date, "d")) Then Sheets(s).Visible = False Else Sheets(s).Visible = True End If Next ورقة34.Visible = False End Sub

شكرا لكل الاخوة الكرام على مرورهم كنت قد اعددت الملف و لكن مشكلة النت هي التي اجلت ارسال الموضوع هذا ملف معدل و به ميزات أخرى ارجو ان ينال رضى الجميع فهد4.rar

صباح الخير اخي يوسف تم تغيير السكرول بار الى 3000 اسم و بالنسبة للفورم اضغط مرتين متتاليتين في اي مكان من الورقة يظهر الفورم -------------------------------------------- * أسعد الله صباحك اخي الحبيب دغيدي * *************************************** فهد 3.rar

جزاك الله خيرا أخي الكريم سعد عابد أسعدك الله في الدنيا و جعلك من العابدين

هذا الفورم بعد التعديل فهد 2.rar

من الخاصية Max للجرار ScrollBar1 غيرها الى ما تريد و هي الاآن متوقفة عند 200

بهذا الكود يمكن ان يتسع الى 256 عمود Private Sub UserForm_Initialize() ÂÎÑ_ÎáíÉ = æÑÞÉ1.Range("IV1").End(xlToLeft).Column Dim ãÑÈÚÇÊ_ÇáäÕæÕ As Control: Dim ãÑÈÚÇÊ_ÇáÚäÇæíä As Control ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' For t = 1 To ÂÎÑ_ÎáíÉ Set ãÑÈÚÇÊ_ÇáÚäÇæíä = Frame1.Controls.Add("forms.label.1", "label" & t, True) With ãÑÈÚÇÊ_ÇáÚäÇæíä .Left = Frame1.Width - 90: .Top = 1 + (t * 15) .Width = 60: .Height = 15: .TextAlign = 3 Frame1.Controls("label" & t).Caption = Cells(1, t) End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set ãÑÈÚÇÊ_ÇáäÕæÕ = Frame1.Controls.Add("forms.textbox.1", "textbox" & t, True) With ãÑÈÚÇÊ_ÇáäÕæÕ .Left = Frame1.Width - 160: .Top = 1 + (t * 15) .Width = 90: .Height = 15: .TextAlign = 3 Frame1.Controls("textbox" & t).Text = Cells(2, t) Frame1.ScrollHeight = Frame1.ScrollHeight + Frame1.Controls("textbox" & t).Height + 2 End With Next t End Sub لو تلاحظ الكود لوجدت اننا غيرنا فقط Z1 بالقيمة IV1

و هذا تحسين للفورم مع ادراج زر الحذف فهد 2.rar

انا عندي 2003 وبالنسبة لـ 2003 نذهب الى الشريط الدي يحتوي على القوائم مثل : ملف ـ تحرير ـ عرض ـ ادراج ............. نختار كلمة ادراج ثم تكمل كما اسلفت لك الذكر اما 2007 فالله اعلم

مشكور اخي الحبيب فهد و جزاك الله خيرا

أخي الحبيب فهد و الله لإنني أسعد دوما بدعواتك الصالحة جمعنا الله و كافة المسلمين في الجنة

ثم عمل اللازم رغم ان الفورم يتطلب بعض التنسيق فهد.rar

شكرا اخي الكريم : / أبو الحارث شكرا اخي الكريم : / فهد جزاكم الله خيرا على المرور العطر

هل بهذه الطريقة التكملة التلقائية.rar

السلام عليكم مثال.rar

يمكنك وضع الكود التالي في الحدث Workbook_Open Private Sub Workbook_Open() For s = 1 To ThisWorkbook.Sheets.Count If Sheets(s).Name < Val(Format(Date, "d")) Then Sheets(s).Visible = False Else Sheets(s).Visible = True End If Next End Sub

بعد اذن اخي ابو لميس هذا مرفق يوضح العمل Book1.rar