الـعيدروس

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

اكيد لايمكن تجاوز حد الصفحه المستويات حسب كل صفحه فقط

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

السلام عليكم جرب هذا الكود فرضاً عمود تاريخ الإنتهاء هو "A" يبدء من "A2" عمود النتيجة "C" Public Sub Ali_Ddif() Dim m_r As Range, my_r As Range Dim Dif_A%, I_a%, m_a%, N_a%, I% With ActiveSheet '******************************************************* Set my_r = .Range("A2") ' عمود تاريخ الإنتهاء '******************************************************* Set m_r = .Range("C2") ' عمود النتيجة '******************************************************* On Error Resume Next For I = 0 To .Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row - 1 If IsDate(my_r.Offset(I, 0)) Then Dif_A = my_r.Offset(I, 0) - Date If Dif_A < 0 Then '******************************************************* I_a = Dif_Ali(Format(my_r.Offset(I, 0), "mm/dd/yyyy"), Format(Date, "mm/dd/yyyy"), "md") m_a = Dif_Ali(Format(my_r.Offset(I, 0), "mm/dd/yyyy"), Format(Date, "mm/dd/yyyy"), "ym") N_a = Dif_Ali(Format(my_r.Offset(I, 0), "mm/dd/yyyy"), Format(Date, "mm/dd/yyyy"), "y") '******************************************************* With m_r.Offset(I, 0) .Font.Color = IIf(N_a >= 0 And m_a >= 0 And I_a >= 0, RGB(255, 0, 0), RGB(0, 176, 80)) .Value = " الإقامة أنتهــت منـذ " & N_a & " سنة , " & m_a & " شهور و " & I_a & " يوم ." End With Else '******************************************************* I_a = Dif_Ali(Format(Date, "mm/dd/yyyy"), Format(my_r.Offset(I, 0), "mm/dd/yyyy"), "md") m_a = Dif_Ali(Format(Date, "mm/dd/yyyy"), Format(my_r.Offset(I, 0), "mm/dd/yyyy"), "ym") N_a = Dif_Ali(Format(Date, "mm/dd/yyyy"), Format(my_r.Offset(I, 0), "mm/dd/yyyy"), "y") '******************************************************* With m_r.Offset(I, 0) .Font.Color = IIf(N_a = 0 And m_a = 0 And I_a <= 0, RGB(255, 0, 0), RGB(0, 176, 80)) .Value = " الأقامة تنتهي بعد " & N_a & " سنة , " & m_a & " شهور و , " & I_a & " يوم . " End With End If End If Next I End With End Sub Private Function Dif_Ali(ByVal Fr_D As String, ByVal Sc_D As String, ByVal St_D As String) As Long Dif_Ali = Evaluate("DATEDIF(DATEVALUE(""" & Fr_D & """),DATEVALUE(""" & Sc_D & """),""" & St_D & """)") End Function أرجو التجربه وبلغنى بالنتائج أفضل أن الطلب يكون في موضوع منفصل لسهولة البحث عنه وكي يستفيدو منه الأخوه الأعضاء تحياتي Datdif_A.rar

السلام عليكم اطلع على المرفق تقريب الارقام_A.rar

أرجو منك ارفاق مثال وبه نتئاج المعادله للتأكد من نتائج الكود واحاول أستبدلها بكود إن شاء الله تحياتي

بإمكانك عمل ليبلات أعلا الليست بحيث تأخذ البيانات من رؤوس الأعمدة أكيد بتقولي والسكرول إيه الحل معاه ؟ في أداة بنظري أنها أروع من الليست إسمها " Listview " تجي لها رؤوس أعمده ثابته إستخدمتها في عمل سابق في هذا المنتدى كي تشاهد إستخدامها http://www.officena.net/ib/index.php?showtopic=41175&st=20 مشاركة رقم 40#

السلام عليكم الأخ الفاضل ضاحي الغريب اشكرك على كلامك الطيب For i = 1 To 35 حلقة بقدر أكبر رقم حسب السطر الذي لديك Cells(Target.Row + 17, 2) = Application.VLookup(Target, MyRng, 33, 0) أرجو أن تكون أتضحت لدبك الصوره تقبل تحياتي

السلام عليكم جرب هذا المعادلة المركبه الصقها في مودويل إستخدامها : =Rd_Ali(خلية الرقم) Public Function Rd_Ali(xx As Double) As Double Dim c#, i#, ii# c = xx - Int(xx) i = 100 * c: ii = Int(i / 5) Rd_Ali = Int(xx) + 5 * ii / 100 End Function أرجو التجربه وابلغنى بالنتائج تحياتي

ألسلام عليكم جرب هكذا Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Set MyRng = Sheet2.[A1:AG1000] If Not Intersect(Target, [B8]) Is Nothing Then With Application For i = 1 To 35 C = Choose(i, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 16, 17, 18, 19) Cr = Choose(i, 2, 20, 27, 6, 4, 12, 7, 23, 24, 25, 26, 18, 33, 19, 22) If C = Null Or Cr = Null Then GoTo 0 Cells(Target.Row + C, 2) = IIf(IsError(.VLookup(Target, MyRng, Cr, 0)), "", .VLookup(Target, MyRng, Cr, 0)) 0 Next End With Set MyRng = Nothing End If End Sub

السلام عليكم جرب المرفق ALIDROOS_F2.rar

السلام عليكم جرب هذا الكود Sub Ali() Set S = Sheets(1): Set Sh = Sheets(2) Application.ScreenUpdating = False For ii = 2 To Sh.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To S.Cells(Rows.Count, 2).End(xlUp).Row If Not IsEmpty(S.Cells(i, 2)) And _ Not IsEmpty(Sh.Cells(ii, 1)) Then If S.Cells(i, 2) = Sh.Cells(ii, 1) And Sh.Cells(ii, 2) = "baghdad" Then S.Cells(i, 3) = Sh.Cells(ii, 2) End If End If Next Next End Sub

السلام عليكم إطلع على المرفق فورم بحث - اوفيسنا_A.rar

السلام عليكم جرب المرفق Zom_A.rar

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

لماذا التكبير لفورم أم زوم للصفحة ؟؟

السلام عليكم إضغط الملف مرتين بمعني إضغطه أول مره ثم انشاء ملف جديد ونقل الملف المضغوط وسط الملف الجديد ثم اضغط الملف الجديد ثم جرب إرفقه

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

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

السلام عليكم جرب هكذا أخي أبو تميم Private Sub UserForm_Initialize() Me.ListBox1.ColumnHeads = False Me.ListBox1.ColumnCount = 5 Dim Rn As Range Dim cl As Range Set Rn = Range("A1:E1") For Each cl In Rn.Columns(1).Cells With ListBox1 .AddItem cl.Offset(, 0) .List(.ListCount - 1, 0) = cl.Offset(, 1) .List(.ListCount - 1, 1) = cl.Offset(, 2) .List(.ListCount - 1, 2) = cl.Offset(, 3) .List(.ListCount - 1, 3) = cl.Offset(, 4) End With Next cl End Sub

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

السلام عليكم الأخ nicola السموحه منك لم اركز على ملاحظتك أنا اجربت أرفقت صورة من الصور التي لدي في الجهاز وظهرت بشكل طبيعي في مربع الصوره Image1 لم يحدث عندي أي خطاء ؟ على العموم إذا لازالت المشكله قائمة جرب ضيف هذا السطر في اول الكود الذي يحدث الخطاء On error resume next تحياتي

استاذي عبدالله باقشير حفظك الله كأعمالك دائما وابداً عمل في قمة الإبداع والاحترافيه جزاك الله كل خير

السلام عليكم أرجو تجربه هذا التعديل التعديل على أنه عدد الخرائط 5 أي بعدد الأزرار التي في Userform2 وأي ملاحظات انا موجود تحياتي فورم مخصص_A1.rar

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