رجب جاويش

تفضلى أختى الفاضلة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 2 Or Target.Count > 1 Then Exit Sub If Target = "" Then Exit Sub On Error Resume Next If Target.Offset(0, -1).Value = 0 Then Target.Value = "" Target.Offset(0, -1).Value = "" MsgBox "من فضلك أدخل القيمة أولا" Target.Offset(0, -1).Select: Exit Sub End If If Target.Offset(0, -1).Value <> 0 Then Target = Format(Target, "DD/mm/YYYY") End If End Sub Book1.rar

كل الشكر والتحية للأستاذ / بن عليه ولإثراء الموضوع هذا كود آخر فى حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [B8:B14]) Is Nothing Then [B1:V1].ClearContents Dim cl As Range ReDim Arr(1 To 21) As String T = 1 For Each cl In [B8:B14,C8:C14,D8:D14] If cl.Value <> "" Then Arr(T) = cl & Cells(7, cl.Column) T = T + 1 End If Next ii = 2 For Each c In Arr If c <> "" Then Cells(1, ii) = c ii = ii + 1 End If Next End If End Sub دفتر نقل2.rar

أخى الغالى / كعبلاوى اليك ما طلبت Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = [C2].Address Then [B5:D1000].ClearContents Dim LR As Integer LR = Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row For Each cl In Sheets("sheet1").Range("C5:C" & LR) If cl = [C2] Then cl.Offset(0, -2).Resize(1, 3).Copy Range("B" & [B1000].End(xlUp).Row + 1).PasteSpecial xlPasteValues Application.CutCopyMode = False End If Next End If End Sub أما معادلة التسلسل الموجودة فى العمود A يمكنك سحبها للأسفل الى أى صف تريد تقيم و مستوى1.rar

السلام عليكم كل الشكر والتحية لكل الأساتذة المشاركين بحلول رائعة عن طريق المعادلات وهذا حل آخر عن طريق الأكواد Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = [C2].Address Then [B5:D47].ClearContents Dim LR As Integer LR = Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row For Each cl In Sheets("sheet1").Range("C5:C" & LR) If cl = [C2] Then cl.Offset(0, -2).Resize(1, 3).Copy Range("B" & [B1000].End(xlUp).Row + 1).PasteSpecial xlPasteValues Application.CutCopyMode = False End If Next End If End Sub تقيم و مستوى1.rar

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

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

أخى الفاضل المطلوب غير واضح الرجاء توضيح المطلوب بتفاصيل أكثر داخل الملف

أخى ابراهيم المرفق موجود فى المشاركة يمكنك تحميله

تفضل أخى الترحيل.rar

بارك الله فيك أستاذ طارق وهذا تعديل فى الكود لتلافى الخطأ فى الكود السابق عند تشابه أكبر رقم فى القائمة للمواد المتكررة Sub ragab() Application.ScreenUpdating = False Dim cl As Range, cll As Range For Each cl In [D5:D28]: For Each cll In [G20:G26] If cl = cll And WorksheetFunction.CountIf(Range("D5:D28"), cl) = 1 Then cll.Offset(0, 1).Value = cl.Offset(0, 1).Value End If If cl = cll And WorksheetFunction.CountIf(Range("D5:D28"), cl) > 1 Then For Each cell In [D5:D28] If cell = cl Then If Val(cell.Offset(0, -1)) > iMX Then iMX = Val(cell.Offset(0, -1)) x = cell.Offset(0, 1) End If End If Next cll.Offset(0, 1).Value = x iMX = 0 End If Next: Next Application.ScreenUpdating = True End Sub LastPrice4.rar

وعليكم السلام ورحمة الله وبركاته تفضل أخى Q.rar

أخى ابراهيم فى حدود معلوماتى أن هذا غير ممكن وغير متاح فى vba والله أعلم

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

شكرا جزيلا أخى الفاضل على هذه الكلمات الطيبة زكل عام وأنتم بخير

سيكون التعديل هكذا Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.StatusBar = ActiveSheet.Name & " " & "بسم الله الرحمن الرحيم" End Sub Book1.rar

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

تفضل أخى ابراهيم يمكنك كتابة المعادلات فى مكان فى sheet1 ويتم تفعيل الكود عند فتح الملف حماية الخلايا المحتوية على معادلات3.rar

أخى الفاضل مرحبا بك بين اخوانك الرجاء ارفاق ملف توضح به ما تريد لارفاق الملف اضغطه أولا ثم ارفقه

بعد اذن أخى الفاضل / عبد الله المجرب أخى ابراهيم كود أخى عبد الله يوضع فى حدث workbook فى حدث تنشيط الشيت Workbook_SheetActivate كالآتى Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.StatusBar = ActiveSheet.Name End Sub Book1.rar

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

أخى الفاضل / tofimoon4 جرب الكود التالى Sub ragab() Application.ScreenUpdating = False Dim cl As Range, cll As Range For Each cl In [D5:D28]: For Each cll In [G20:G26] If cl = cll And WorksheetFunction.CountIf(Range("D5:D28"), cl) = 1 Then cll.Offset(0, 1).Value = cl.Offset(0, 1).Value End If If cl = cll And WorksheetFunction.CountIf(Range("D5:D28"), cl) > 1 Then If Val(cl.Offset(0, -1)) > iMX Then iMX = Val(cl.Offset(0, -1)) x = cl.Offset(0, 1) End If cll.Offset(0, 1).Value = x End If Next: Next Application.ScreenUpdating = True End Sub آخر سعر1.rar

أخى الفاضل جرب هذا الكود Sub ragab() Dim cl As Range, sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Not sh.Name = "Sheet1" Then sh.Range("A1:G1000").ClearContents End If Next LR = Cells(Rows.Count, 2).End(xlUp).Row For Each cl In Range("B2:B" & LR) x = Trim(cl.Value) On Error Resume Next If Worksheets(x) Is Nothing Then Sheets.Add.Name = x Sheets(x).Move After:=Sheets(Sheets.Count) End If Sheets("sheet1").Range("A1:G1").Copy Sheets(x).Range("A1").PasteSpecial xlPasteValues Sheets(x).Range("A1").PasteSpecial xlPasteFormats cl.Offset(0, -1).Resize(1, 7).Copy Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False Next MsgBox "تم الترحيل بنجاح الى صفحات منفصلة" Sheets("sheet1").Select Application.ScreenUpdating = False End Sub كود ترحيل.rar

أخى ابراهيم جرب هذا التعديل Sub ragab() Application.ScreenUpdating = False Dim cl As Range For Each cl In [D5:D28]: For Each cll In [G20:G26] If cl = cll Then cll.Offset(0, 1).Value = cl.Offset(0, 1).Value End If Next: Next Application.ScreenUpdating = True End Sub

لاثراء الموضوع هذا حل بالأكواد Sub ragab() Dim cl As Range For Each cl In [D5:D28]: For Each cll In [G20:G26] If cl = cll Then cll.Offset(0, 1).Value = cl.Offset(0, 1).Value End If Next: Next End Sub آخر سعر.rar

أخى شاهد هذا الفيديو ليؤكد لك أن الملف يعمل بشكل سليم