عبدالله المجرب

السلام عليكم تم اضافة ملاحظة للحل هنا http://www.officena....showtopic=42223

السلام عليكم اليك ملفك وقد اضفت اليه كود الاستاذ خبور للدوائر وهو الافضل من وجهة نظري جرب المرفق واعلمني بالنتيجة الثالث.rar

استبدل هذا "Û" ب "غ" وهذا "ÜÛ" ب "غـ"

اخي دالة DateDif تعمل مع 2007 ولكنها ليست ضمن الدول ولا بد من كتابتها

بارك الله فيك اخي ابو ردينة على هذا التنبيه ونتمى من الجميع الالتزام

الحمدلله ان اطمئنا عليك وعلى ابو الحارث

سيصبح كودك هكذا ==================== Sub sDrawOval() If TypeName(Selection) "Range" Then Exit Sub Dim ssRange As Range Set ssRange = Selection DrawOvals ssRange, 60, 0.1 End Sub Function fDrawOval(ByVal fRange As Range, MinDegree As Single, MarginRatio As Single) As String Application.Volatile DrawOvals fRange, MinDegree, MarginRatio fDrawOval = "" End Function Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single) Dim cCell As Range Dim shShape As Shape Dim OvName As String, OvSheet As String On Error GoTo DR_OVAL_Err For Each cCell In sRange OvName = "oval" + cCell.AddressLocal OvSheet = cCell.Worksheet.Name If IsExistShape(OvName, OvSheet) Then 'If cCell.Value >= MinDegree Or cCell.Formula = "" Then If (cCell.Value >= MinDegree Or cCell.Formula = "") And (cCell.Value "غ" And cCell.Value "غـ") Then cCell.Worksheet.Shapes(OvName).Delete End If Else 'If cCell.Value < MinDegree And cCell.Formula "" Then If cCell.Value < MinDegree And cCell.Formula "" Or (cCell.Value = "غ" Or cCell.Value = "غـ") Then MrH = OvMargRatio * cCell.Height MrW = OvMargRatio * cCell.Width OvalW = cCell.Width - MrW OvalH = cCell.Height - MrH Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeRectangle, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Transparency = 1# .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) .Line.Weight = 1# End With End If End If Next Set cCell = Nothing Exit Function DR_OVAL_Err: MsgBox Err & " : " & Error Err.Clear Resume Next End Function Function IsExistShape(ShapeName As String, SheetName As String) As Boolean Dim shShape As Shape IsExistShape = False For Each shShape In ThisWorkbook.Worksheets(SheetName).Shapes If shShape.Name = ShapeName Then IsExistShape = True Exit Function End If Next shShape End Function

استبدل الكود السابق بهذا Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [C46:C66]) Is Nothing Then If Target.Value = Empty Then Target.Offset(0, 1) = "" For Each cl In [B3:B38] If cl = Target Then Target.Offset(0, 1) = cl.Offset(0, 1): Exit Sub Next End If End Sub </p>

ما شاء الله تبارك الله لم تخطر ببالي هذه الفكرة صار لي يومين احاول مع حدث التغيير في الخلية زادك الله من علمه اخي ابو حنين فكرة ممتازة

لا ان شاء الله السلسلة مستمرة ولكن المشاغل هي السبب

احي ابراهيم ما هو سبب عدم كتابة عنوان مناسب ارجو منك الاجابة ============================== الحل لسوالك ضع هذا الكود في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [C46:C66]) Is Nothing Then For Each cl In [B3:B38] If cl = Target Then Target.Offset(0, 1) = cl.Offset(0, 1): Exit Sub Next End If End Sub

اضغط على زر Esc (مرة او عدة مرات) وسيتم ايقاف الكود وتلوين السطر الذي وصل اليه الكود

اخي الكريم الدالة Um2Greg هي دالة معرفة اي لا بد من وضع كودها في اي ملف تريد استعمالها فيه اذاً لكي تعمل معك الدالة ضع كود الدالة في محرر الاكواد ثم استعملها كما تريد

اتقدم بالاصالة عن نفسي ونيابة عن جميع الاعضاء بالتهنئة الى الاخ الكريم mahmoud-lee بمناسبة ترقيته الى عضو مميز وان شاء الله نرى فيه النشاط المعهود دائماً === سينقل الموضوع الى المنتدى الاجتماعي بعد فترة

شاهد المرفق فصل الراسب فى شيت والناجح فى شيت اخر.rar

ممكن ذلك فاذا كنت تستخدم كود الاستاذ خبور فالتعديل سيكون في هذا السطر Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6)

ضع هذه المعادلة في الخلية C2 ثم اسحب الى الاسفل =IF(OR(B2=0;B2="");"";IF(A2<>0;LOOKUP(B2;H$7:I$11);" "))

كل الشكر للاخوة الكرام رجب جاويش ومحمود والاخ الفرس على الحلول المقدمة == اخي الكريم اين تريد البيانات المكررة

السلام عليكم اخي الفاضل الكود يعمل ولكن الخلل في الخلية U4 في شيت ناجح وشيت دور ثان قم بالاتي 1. ازالة الدمج عن هذه الخلية 2. وضع المسمى "النتيجة" في الخلية U6 في كلا الشيتين 3. فعل الكود وسترى النتيجة

جرب هذا التعديل Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo 1 If Not Intersect(Target, [F2:F100]) Is Nothing Then Application.ScreenUpdating = False If Target.Value = "" Then Exit Sub Target.Offset(0, -5).Resize(1, 6).Copy Sheets("ورقة2").Range("A" & Sheets("ورقة2").[A1000].End(xlUp).Row + 1).PasteSpecial xlPasteValues Target.Offset(0, -5).Resize(1, 6).Delete Shift:=xlUp Application.CutCopyMode = False End If 1 End Sub

السلام عليكم اليك المطلوب الاول جرب تكتب في خلية عمود F سيتم الترحيل الرسائل.rar

اخي مجدي لا داعي للاستاذان بارك الله فيما تقوم به من نشر للعلم

للرفع

ما رايك بهذا التعديل الناجحون والراسبون والعشرةالاوائل.zip

اليك الرابط http://www.officena.net/ib/index.php?showtopic=41919&st=20&p=239466&#entry239466