حسين العصلوجى

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then For x = 2 To Range("b65536").End(xlUp).Row If Cells(x, "b") <> "" Then Cells(x, "A") = Cells(x - 1, "A") + 1 End If Next End If End Sub اثراءا للموضوع حل اخر بالاكواد لتجنب كتابة المعادلات في كل خلية لعله يفى بالغرض H-Classeur1.rar

http://www.officena.net/ib/index.php?showtopic=45739&hl= شوف الموضوع ده المرفق الموجود بالمشاركة رقم 11 يعمل كالاتي:- * اذا كان سوق الاسهم مغلق فالكود لايعمل. * اذا كان مفتوح يسجل في العمود ar اول ارتفاع لفيمة السهم عن سعره الافتتاحي وهذا لاول مره فقط وفي العمود as وقت هذا الارتفاع. اتمني ان يفي بالغرض وفي حالة رغبتك بالتعديل عليه اطرح تعديلاتك وستجد العون ليس مني فقطولكن من كل اساتذة وخبراء هذا المنتدي العظيم

بارك الله لك يا اخي خالد علي هذه الكلمات الطيبة

تصحيح الكود كالتالى Private Sub Worksheet_Change(ByVal Target As Range) If Not IsEmpty(Target) Then For x = 13 To 290 If Cells(x, 41) > Cells(x, 40) And Cells(x, 44) = "" Then Cells(x, 44) = Cells(x, 41) Cells(x, 45) = Format(Now, ("HH:MM:SS")) End If If Cells(x, 41) > Cells(x, 44) And Not Cells(x, 44) = "" And Cells(x, 46) = "" Then Cells(x, 46) = Cells(x, 41) Cells(x, 47) = Format(Now, ("HH:MM:SS")) End If Next End If End Sub الملف المرفق عملت لك فيه ان الكود لايعمل مادام السوق مغلق حتي لايخرج نتائج علي بيانات اليوم السابق فتكون خاطئة وكذلك عند فتح الملف يحذف الارتفاعات القديمة H-activecell (3).rar

شوف الفكره دي لو عجبتك طبقها علي باقي الكومبو والتكست بوكس انا طبقتها علي الكومبوبوكس 1 فقط للتجربة اعمل Disable لbutton 1 ثم اضف هذا الكود Private Sub ComboBox1_AfterUpdate() [A6] = ComboBox1.Value If [A6] <> [A5] Then CommandButton1.Enabled = True End If End Sub اضف هذا الكود في حدث USERFORM ACTIVATE [A5] = ComboBox1.Value اضافة خاصية تحسس التعديل على البيانات في الفورم -h.rar

الف مليون مبروك يا ا/ ابو محمد

اثراءا للموضوع كود اخر لتنفيذ المطلوب Sub Aslogy() Application.ScreenUpdating = False Set ws = Sheets("data") Set ws2 = Sheets("Call") Range("a4:h65536").ClearContents RF = Application.Match(Val([c1]), ws.Range("b1:b65536"), 0) ws.Select Rows(RF).Select Selection.Copy ws2.Select Cells(Range("a65536").End(xlUp).Row + 1, 1).Select Selection.PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End Sub

Sub MACRO20() ActiveWorkbook.Application.DisplayFullScreen = False ActiveWorkbook.Application.CommandBars("FULL SCREEN").Visible = True ActiveWorkbook.Application.CommandBars("WORKSHEET MENU BAR").Enabled = True ActiveWorkbook.Application.CommandBars("STANDARD").Visible = True ActiveWorkbook.Application.CommandBars("FORMATTING").Visible = True ActiveWorkbook.Application.DisplayStatusBar = True ActiveWorkbook.Application.DisplayFormulaBar = True End Sub Sub MACRO21() ActiveWorkbook.Application.DisplayFullScreen = True ActiveWorkbook.Application.CommandBars("FULL SCREEN").Visible = False ActiveWorkbook.Application.CommandBars("WORKSHEET MENU BAR").Enabled = False ActiveWorkbook.Application.CommandBars("STANDARD").Visible = False ActiveWorkbook.Application.CommandBars("FORMATTING").Visible = False ActiveWorkbook.Application.DisplayFormulaBar = False End Sub

تفضل المرفق لعله يفى بالغرض أعمالـــــــــ السنة_H.rar

اخي / احمد الملف يعمل ولا يوجد به مشكلة انا وضحت لك اللي هاتعمله فالمرفق Book2_H.rar

عدلت لك الملف ليتناسب مع طلبك لعله يكون المطلوب - وتم تطبيق التغيير علي الملف بالكامل نموذج_h.xls

بعد اذن استاذنا الجليل طارق محمود تفضل المرفق لعله يفى بالغرض Book2_H.rar

اخي الغالي / حماده عمر انت تكتب ما شئت واينما شئت وياباشا من حق الكبير يدلع ههههههههههههه

طلبك بالمرفق ولو في اي تعديل تاني تجده ان شاء الله تفقيط_H.rar

طلبك بالمرفق ولو في اي تعديل تاني تجده ان شاء الله

جرب هذا المرفق ولو في ملاحظات عرفني activecell (3).rar

تفضل المرفق لعله يكون المطلوب تفقيط_H.rar

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

الاخ / ناصر ارفق الملف الذي يتم جلب البيانات منها لاضافة الكود المناسب له ليعمل علي التحدبث التلقائي المرفق به مثال لعله يكون المقصود activecell (3).rar

من الطبيعى ان لاتتغير القيم في الشيتات المنسوخه لان الكود يعمل علي حدث تغير المحتوي بالورقة عموما عدلت لك الكود ليتناسب مع طلبك اتمني ان يفي بالغرض husin1 (2).rar

لم يتضح لي طلب برجاء التوضيح بمثال في الملف وان شاء الله تجد المطلوب

الاخ / كرتوتي اذا كان ماقلته في المشاركة رقم 6 هو ما تريده اخبرني وسوف اقوم باعداد المطلوب ان شاء الله

Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False 'unhide all colums If Target.Column = 17 And Target.Row = 9 Then For i = 1 To 35 Columns(i).Hidden = False Next 'hide columns not included in thr selected month d = Format(DateSerial(Year(Range("Q9")), Month(Range("Q9")) + 1, 0), "dd") For x = d + 2 To 32 Columns(x).Hidden = True Cells(15, x) = "" Next Else Exit Sub End If 'renumber days Z = 1 For x2 = 2 To 32 Cells(14, x2) = Z Z = Z + 1 Next 'replace fridays days with Fr dependig on fromula (IF(WEEKDAY(Q9;1)=6;DAY(Q9);CHOOSE(WEEKDAY(Q9;1);DAY(Q9+5);DAY(Q9+4);DAY(Q9+3);DAY(Q9+2);DAY(Q9+1);DAY(Q9+0);DAY(Q9+6)))) For x = 2 To 32 If Cells(14, x) = Cells(12, 15) Or Cells(14, x) = Cells(12, 16) Or Cells(14, x) = Cells(12, 17) Or Cells(14, x) = Cells(12, 18) Or Cells(14, x) = Cells(12, 19) Then Cells(14, x) = "fr" End If Next End Sub تفضل اخي المرفق بعد التعديل لعله يكون المطلوب husin1 (2).rar

الحل بالمشاركة التالية

Dim ws As Worksheet Set ws = Sheets("58") i = 1 For x = 1 To 14 If Cells(x, 5) = 1 Then ws.Cells(10 + i, 1) = Cells(x, 1) i = i + 1 End If Next تفضل المرفق لعله يكون المطلوب Book1-h.rar