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

السلام عليكم استعمل هذا الكود في زر أمر Sub Abu_Ahmed() Dim cl As Range For Each cl In [G1:G7] If Application.CountIf([A1:D3], cl) = 0 Then [E1] = cl Next End Sub

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

صدق الاستاذ ابو نصار لم راي الماسة المنتدى الرد يمكن فاتتنا هذه المعلومة الجميلة تواضع وبذل بارك الله فيكم جميعاً

السلام عليكم تم اصلاح الخطاء كما تم إضافة كود العلامة خبور لوضع الدوائر الحمراء شهادات 1ع.rar

السلام عليكم بعد اذن ابونصار اخي فضل اليك هذه المعزوفة التي ستحقق ما تريد بإذن الله Sub Abu_Ahmed_Filter() Application.ScreenUpdating = False Range("MyRng").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ "A1:A2"), CopyToRange:=Range("A7:F7"), Unique:=False End Sub كود نسخ بشرط 3.rar

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

السلام عليكم اخي المهم هو الحصول على هذا الرقم

ما شاء الله الماسة جديدة تضعها بين يدينا لا نملك الا ان نتوجه لله لك بالدعاء بالبركة في المال والرزق

جرب المرفق وميض4.rar

اين المرفق !!!!!!!!!

شاهد هذا الموضوع http://www.officena.net/ib/index.php?showtopic=38622 او هذا http://www.officena.net/ib/index.php?showtopic=9113

جرب هذا الرابط http://www.officena.net/ib/index.php?showtopic=39795

عمل مميز استاذ عبدالله

تم فصل الموضوع (لاختلافه عن الموضوع الملحق به) == تم حل المشكلة شيت الثانى والرابع.zip

السلام عليكم بعد اذن ابو نصار تعديل طفيف على الكود ليصبح Sub ALIDROOS_JC() With Sheets("Sheet1").Columns(2).Rows(65536).End(xlUp) .Offset(1, 0) = [D12] .Offset(1, 1) = [S12] .Offset(1, 2) = [E14] .Offset(1, 3) = [E14] .Offset(1, 4) = [AB15] .Offset(1, 5) = [AL13] .Offset(1, 6) = [E15] .Offset(1, 7) = [P14] .Offset(1, 8) = [R20] & " " & [Y20] & " " & [AC20] _ & " " & [AD20] & " " & [AF20] & " " & [AI20] & " " & [AJ20] End With MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "تم الترحيل" End Sub

السلام عليكم راجع هذا الموضوع http://www.officena.net/ib/index.php?showtopic=37489

الاستاذ الفاضل محمد يحياوي ترقية مستحقة ومنها للاعلى

جرب المرفق عبدالله المجرب.rar

جرب المرفق BGR2.zip

السلام عليكم المطلوب بحاجة الى شويت وقت وخصوصاً بان الارقام التي على يمين الرقم ويساره ليست ثابته فاعذرني على التأخر في الرد (ساحاول ولكن دون وعد بالحل)

اخي اضغط الملف قبل ارفاقة ببرنامج وينرار

السلام عليكم ضع هذا في حدث ورقة العمل Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("A1:A50")) Is Nothing Then x = Target.Interior.ColorIndex For i = 1 To 3 Target.Offset(0, i).Interior.ColorIndex = x Next End If End Sub

السلام عليكم تفضل المرفق منتجات.rar

السلام عليكم اخي زوهير جرب المرفق تم اضافة زر لعرض النتائج كما لم يتم عرض لمسح البيانات لان ذل اثر على النطاق المعرف جرب وابد الراي TESTE (1).rar

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