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

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