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

وضح أكثر

ماذا عن الاسم

السلام عليكم اخي ابوتميم اضف هذا السطر الى الكود في صفحة main Sheets(Application.Text((Target.Value), "@")).[C6] = Target.Value ليصبح Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo 1 If Not Intersect(Target, [A5:A13]) Is Nothing Then Cells(Target.Row, 9) = Sheets(Application.Text((Target.Value), "@")).[E11] Cells(Target.Row, 10) = Sheets(Application.Text((Target.Value), "@")).[G11] Cells(Target.Row, 11) = Sheets(Application.Text((Target.Value), "@")).[A15] Cells(Target.Row, 12) = Sheets(Application.Text((Target.Value), "@")).[F11] End If Sheets(Application.Text((Target.Value), "@")).[C6] = Target.Value 1 End Sub

الى الغد ان شاء الله ان لم يقم احد الاخوة بالتعديل المطلوب

السلام عليكم اليك الشرح ============ قمت بإختصار الكود Sub ALIDROOS_JC_T() Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets For R = 2 To [A1000].End(xlUp).Row If Cells(R, 4).Value = sh.Name And Cells(R, 4).Value <> Empty Then Cells(R, 1).Resize(1, 11).Copy sh.Range("A" & sh.[A1000].End(xlUp).Row + 1) End If Next Next Application.CutCopyMode = False End Sub

ما شاء الله ملف رائع واكواد مفيدة بارك الله فيك استاذ يحياوي

اخي جرب مراجعة هذا الرابط http://www.officena.net/ib/index.php?showtopic=39323

السلام عليكم تم استبدال المعادلات باكواد وتعمل الاكواد بلتغير في الخلية استبدال المعادلة Vlookup والارتباط التشعبي بكود يعمل نفس العمل.rar

شكراً لك استاذ طارق على الدعم والمساندة وهذا من فضل الله ثم ما تعلمناه منكم

افتح موضوع جديد وضع به مرفق

السلام عليكم ضع مرفق

السلام عليكم ضع هذا الكود في حدث الورقة PART 1 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Set MyRng = Sheets("1").[B6:I4090] If Not Intersect(Target, [H2,H22,H42]) Is Nothing Then Cells(Target.Row + 5, 5) = Application.VLookup(Target, MyRng, 3, 0) Cells(Target.Row + 7, 5) = Application.VLookup(Target, MyRng, 4, 0) Cells(Target.Row + 9, 5) = Application.VLookup(Target, MyRng, 8, 0) Cells(Target.Row + 11, 5) = Application.VLookup(Target, MyRng, 6, 0) End If End Sub

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

السلام عليكم عمل جميل جداً لي استفسار الى ماذا ترمز هذه الرموز (yah) - (med) - (nnn1) في هذه الاسطر SaveSetting "yah", "med", "nnn1", (TextBox1.Text) SaveSetting "yah", "med", "nnn2", (TextBox2.Text) ========= الحمدلله تم معرفة الرموز ماذا تعني وذلك بمتابعة هذا الرابط http://www.officena.net/ib/index.php?showtopic=3974

جرب هذا الكود Sub bbb() A = InputBox("ادخل القيمة التي تريد", "تنبيه", 1) If Not A <> Empty Then Exit Sub Cells(1, 1) = A End Sub

اخي حسن اخي ابووائل شكراً لدعمكم

الملف يعمل عندي بصورة صحيحة شاهد الصورة

بارك اله فيك اخي الزير (ابووائل) ذكرتني بطلبي الذي قام بحله الاستاذ ياسر خليل جهد كبير واكواد متقنه ودليل استاذ محترف ان شاء الله نراك دوماً بيننا ====== ملاحظة الاخ احمد البحيري موفقة واجابتك رائعة وسرعة الرد دليل احتراف

اخي فضل سيصبح الكود هكذا Sub Abu_Ahmed_2nd() Dim cl As Range, cel As Range Set MySh = Sheets("Sheet1") [D8:J100].ClearContents For i = 4 To 28 ww = 0 For J = 1 To 5 t = Application.CountIf(MySh.Cells(i, J + 4), "<" & MySh.Cells(3, J + 4)) If t = 1 Then ww = ww + 1 Next If MySh.Cells(i, 2) = [L2] And MySh.Cells(i, 3) = [L3] And ww >= 1 And ww <= 2 Then Cells(Range("D1000").End(xlUp).Row + 1, 4) = MySh.Cells(i, 2).Offset(0, -1) Cells(Range("D1000").End(xlUp).Row, 10) = "دور ثان" For Each cel In MySh.Range(MySh.Cells(i, 5), MySh.Cells(i, 9)) If (cel < MySh.Cells(3, cel.Column) Or cel = "Û") And ww <= 2 Then Cells(Range("D1000").End(xlUp).Row, cel.Column) = cel Else: GoTo 2 End If 2 Next Else: GoTo 1 End If 1 Next Set MySh = Nothing End Sub

السلام عليكم اخي حسن اليك ما طلبت دوال الالوان.rar

جرب المرفق Book1_2 (2).rar

السلام عليكم اخي الزير شكراً لك ==== اخي فضل ضع هذه المعادلة في الخلية J8 ثم اسحبها للاسفل =IF(D8<>"";"دور ثان";"")

اخي الكريم بالنسبة لو كان العدد 10000 فستكون المعادلة بنفس الكفاءة == بخصوص اضافة التاريخ المطلوب غير مفهوم لذا ارجو منك وضع النتائج المرجوة يدويا ليتم العمل عليها بالمعادلات

السلام عليكم اخي ابو تميم استبدل الكود بهذا Private Sub Worksheet_SelectionChange(ByVal Target As Range) [C3].Value = "" If Not Intersect(Target, [A11:C23]) Is Nothing Then [C3].Value = Cells(Target.Row, 1).Value End If Application.ScreenUpdating = False End Sub

السلام عليكم جرب المرفق بعد التعديل Book1_2.rar