أبو حنــــين

لا عليك اخي عطاء الله فأنا لم اشارك إلا بتساؤل لكن هذه المرة شاركت بمحاولة حد الطلب1.rar

جزاك الله خيرا اخي قنديل الصياد نرتقب المزيد ان شاء الله

السلام عليكم ما هي الخلية التي تريد تلوينها باللون الاحمر

السلام عليكم انظر الفيديو AAA.rar

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

السلام عليكم استعمل هذا الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) With ActiveCell A = .Font.Size Cells.Font.Size = .Font.Size .Font.Size = A * 3 .Columns.EntireColumn.AutoFit End With End Sub

السلام عليكم اعتقد ان المشكلة كما في الصورة المرفقة و الله اعلم 1.rar

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

السلام عليكم لم اجد المعادلات في الملف

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

السلام عليكم جزاك الله خيرا اخي ربيع شوقي على هذا العمل المميز

السلام عليكم جرب المرفق هل بهذه الطريقة البحث 3333في عدة أعمدة.rar

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

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

السلام عليكم اخي لم افهم طلبك الذي قمت به هو ان البيانات تنقل من ورقة All الى باقي الأوراق و عند اضافة بيانات اخرى تنقل بشكل طبيعي تحت البيانات السابقة هل عند نقل البيانات تمسح الورقة الاساسية الى حين ملؤها من جديد ثم اعادة نقل البيانات الجديدة اذا كان الامر كذلك ، فالكود يقوم بهذا العمل ، و ان كان هناك تفسير آخر ارجو التوضيح تحياتي

السلام عليكم أخي الأستاذ أحمد جزاكم الله خيرا

أخي قنديل الصياد جزاك الله خيرا

أخي : إبراهيم أخي : حمادة أخي : يوسف جزاكم الله خيرا على الكلمات الطيبة حفظكم الله و رعاكم

السلام عليكم اخي قم بتغيير السطر التالي If Cells(a, 7) = "يعتمد" Then بهذا السطر If Cells(a, 7) = Cells(1, 12) Then و هذا السطر ايضا If Cells(y, "g").Value = "يعتمد" Then Rows(y).EntireRow.Delete بهذا السطر If Cells(y, "g").Value = Cells(1, 12) Then Rows(y).EntireRow.Delete

السلام عليكم Private Sub CommandButton1_Click() Dim LRR As Long, LR As Long Dim Bb '---------------------------------------------------------------------------------------------- LRR = Sheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row LR = Cells(Rows.Count, "a").End(xlUp).Row '---------------------------------------------------------------------------------------------- If Application.Intersect(Range("A2:C" & LR), ActiveCell) Is Nothing Then GoTo 1 '---------------------------------------------------------------------------------------------- ActiveRow = ActiveCell.Row If MsgBox("هل تريد حذف هذا السجل من قاعدة البيانات", vbCritical + _ vbMsgBoxRight + vbYesNo, "حذف") = vbNo Then Exit Sub '---------------------------------------------------------------------------------------------- For Each Bb In Sheets("Sheet2").Range("B2:B" & LRR) If Bb = Cells(ActiveCell.Row, 2) Then Bb.Offset(0, 1) = Val(Bb.Offset(0, 1)) + Val(Cells(ActiveCell.Row, 2).Offset(0, 1)) Next '---------------------------------------------------------------------------------------------- Sheets("Sheet1").Range(Cells(ActiveRow, 1), Cells(ActiveRow, 3)).Delete MsgBox "تم حذف السجل و تم اضافة قيمته الى قاعدة البانات ", vbInformation + vbMsgBoxRight, "تم الحذف" Sheets("Sheet1").Range("A2") = 1: Sheets("Sheet1").Range("A3") = 2 Sheets("Sheet1").Range("A2:A3").AutoFill Destination:=Range("A2:A" & LR - 1), Type:=xlFillDefault Exit Sub '---------------------------------------------------------------------------------------------- 1 MsgBox "الخلية الحالية خارج نطاق الجدول .", vbExclamation, "خطأ" '---------------------------------------------------------------------------------------------- End Sub

السلام عليكم اخي حمادة ما رأيك في هذا التعديل Private Sub CommandButton1_Click() Application.DisplayAlerts = False If ThisWorkbook.Sheets.Count = 1 Then GoTo 1 For Each sh In ThisWorkbook.Sheets If sh.Name <> ComboBox1.Value Then sh.Delete Next ComboBox1_AddItem Exit Sub 1 MsgBox "لا يمكن حذف الورقة الحالية", vbInformation + vbMsgBoxRight, "خطأ" End Sub Private Sub UserForm_Initialize() ComboBox1_AddItem End Sub Sub ComboBox1_AddItem() ComboBox1.Clear For t = 1 To ThisWorkbook.Sheets.Count R = Sheets(t).Name ComboBox1.AddItem R Next End Sub

جزاك الله خيرا أخي أبو سما

السلام عليكم بعد اذن لخي حمادة استعمل هذا الكود بدل الكود السابق Private Sub CommandButton1_Click() Dim ActiveRow As Long, LastSheet2 As Long, ActivShet As Long Dim DeleteValue, ActiveValue '---------------------------------------------------------------------------------------------- LastSheet2 = Sheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row ActivShet = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row '---------------------------------------------------------------------------------------------- If Application.Intersect(Range("A2:C" & ActivShet), ActiveCell) Is Nothing Then GoTo 1 '---------------------------------------------------------------------------------------------- ActiveRow = ActiveCell.Row If MsgBox("هل تريد حذف هذا السجل من قاعدة البيانات", vbCritical + _ vbMsgBoxRight + vbYesNo, "حذف") = vbNo Then Exit Sub '---------------------------------------------------------------------------------------------- For Each DeleteValue In Sheets("Sheet2").Range("B2:B" & LastSheet2) For Each ActiveValue In Sheets("Sheet1").Range("B2:B" & ActivShet) If DeleteValue.Value = ActiveValue.Value Then DeleteValue.Offset(0, 1).Value = _ Val(DeleteValue.Offset(0, 1)) + Val(ActiveValue.Offset(0, 1)) Next: Next '---------------------------------------------------------------------------------------------- Sheets("Sheet1").Range(Cells(ActiveRow, 1), Cells(ActiveRow, 3)).Delete MsgBox "تم حذف السجل و اضافة قيمته الى قاعدة البيانات", vbInformation + vbMsgBoxRight, "حذف" Sheets("Sheet1").Range("A2") = 1: Sheets("Sheet1").Range("A3") = 2 Sheets("Sheet1").Range("A2:A3").AutoFill Destination:=Range("A2:A" & ActivShet - 1), Type:=xlFillDefault Exit Sub 1 MsgBox "الخلية الحالية خارج نطاق البيانات", vbExclamation, "خطأ" End Sub

السلام عليكم على افتراض انك تريد الحفاض على ورقة1 تكتب الكود التالي Private Sub CommandButton1_Click() Application.DisplayAlerts = False For Each sh In ThisWorkbook.Sheets If sh.Name <> "ورقة1" Then sh.Delete Next End Sub

السلام عليكم نعم اخي سعد افتح ملف اكسل و ضع به زر ثم اضف هذا الكود Private Sub CommandButton1_Click() For i = 1 To 255 Cells(i, 1) = Chr(i) Next End Sub