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

السلام عليكم ذكرتني بالذي مضى الملف لي وكنت قد سألت عن جواب لادراج الصورة من ملف خارجي والجواب لبن عليه واليك الرابط http://www.officena.net/ib/index.php?showtopic=35652 ========== واذا اردت موضوع اكثر احترافية للتعامل مع الصور من ملف خارجي فاليك هذا الرابط http://www.officena.net/ib/index.php?showtopic=40613

السلام عليكم اليك هذا الرابط http://www.officena.net/ib/index.php?showtopic=38766&st=0&p=211998&#entry211998

الاستاذ الفاضل بن عليه الاستاذ الفاضل طارق بارك الله فيكم ونفع بعلمكم

وضح أكثر

ماذا عن الاسم

السلام عليكم اخي ابوتميم اضف هذا السطر الى الكود في صفحة 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<>"";"دور ثان";"")