نجوم المشاركات

عد اذن اخي علي هذا الكود (سريع جداُ لانه يستعمل adanvced filter) Option Explicit Sub filter_for_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim i%, k%: k = Sheets.Count Dim S_sh As Worksheet: Set S_sh = Sheets("سحب مباشر") Dim T_sh As Worksheet Dim My_Table As Range: Set My_Table = S_sh.Range("b3").CurrentRegion For i = 2 To k Set T_sh = Sheets(i) With T_sh .Range("b3").CurrentRegion.Clear .Range("q1") = "العنوان" .Range("q2") = T_sh.Name End With My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("Q1:q2"), _ CopyToRange:=T_sh.Range("b3") T_sh.Range("q1:q2").ClearContents Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق salim_Adv_Fllter.xlsm

If KeyCode = 27 Then DoCmd.OpenForm "frm1" End If

حاول بعد الحدث If Me.الاسم = "مصاريف2" Then جهة_التوزيع.Locked = True End If

45 - 33 ! 35 # 36 $ 37 % 38 & 40 ( 41 ) 42 * 44 , 46 . 47 / 58 : 59 ; 63 ? 64 @ 91 [ 92 \ 93 ] 94 ^ 95 _ 96 ` 123 { 124 | 125 } 126 ~ 39 ‘ 43 “ 43 + 60 < 61 = 62 > 48 0 49 1 50 2 51 3 52 4 53 5 54 6 55 7 56 8 57 9 65 A 97 a 8 Arrow to left 66 B 98 b 67 C 99 c 68 D 100 d 69 E 101 e 13 Enter 27 Esc 70 F 102 f 71 G 103 g 72 H 104 h 73 I 105 i 74 J 106 j 75 K 107 k 76 L 108 l 77 M 109 m 78 N 110 n 79 O 111 o 80 P 112 p 81 Q 113 q 82 R 114 r 83 S 115 s 32 Space 84 T 116 t 9 Tab 85 U 117 u 86 V 118 v 87 W 119 w 88 X 120 x 89 Y 121 y 90 Z 122 z

السلام عليكم ورحمة الله وبركاته مرفق إلى حضراتكم ملف إكسل لجدول مباريات كاس العالم 2018 الروابط https://up.top4top.net/downloadf-702bt7pr1-rar.html أو https://www.4shared.com/office/ZchKus7Lca/World_Cup_Russia_2018_Chart__B.html كلمة السر للملف لمن يرغب في رؤية المعادلات RCUDLNXBVYOVBLS كلمة سر محرر أكواد VBA هي 92EZD9 نسخة مفتوحة بالكامل https://www.4shared.com/rar/ZAqGFyPica/World_Cup_Russia_2018_Chart__B.html نفعكم الله به آمين

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

احفظ الملف يصيغة xlsm

وعليكم السلام ورحمة الله وبركاتة بالنسبة لعدم تغيير تنسيق الخطوط حاول استخدام أحد الخطوط التي تأتي مدمجة مع windos فلو اخترت احد الخطوط الخاصة التي تضاف من قبل المستخدم مثل خط المهند احتمال أن لايكون الخط مثبت في الجهاز الذي ستنقل قاعدة البيانات اليه وهنا سيقوم الاكسس بعرض الخط الافتراضي وستلاحظ ان التنسيق تغير بالنسبة للنماذج وهنا اعتقد تقصد أرار الأمر فلاحظ الصورة التالية أخيراً حاول تقليل الاحداث التي تكون عند تحميل النموذج او فتحه فبحسب تجربتي ان النموذج او التقرير الذي تكون به الاحداث كثيرة يتأخر في عرضة و يظهر تنسيق الخطوط فيه احياناً غير التنسيق الذي تم أختياره ::بالتوفيق::

تفضل هذا ما طلبت بالمعادلات 1.xlsm

تفضل اخى

اخى اشكرك على اهتامك بكره ان شاء الله حبعتلك اخر تشغل عملته وتقولى ايه رأيك ولو فى تطوير او فكرة حبيت نضيفه اكون ممنون عشان نطلع ببرنامج ممتاز ماشي

Multi Val.accdb

المسألة واضحة ليست بحاجة الى شرح تم الاعلان عن متغير mys اذا تم الفتح بطريقة نظامية المتغير سيحمل القيمة 5 عند فتح اي نموذج والقيمة لا تساوي 5 يتم اغلاق قاعدة البيانات مرفق مثال بدون الوحدة النمطية التي تحمل قيمة mys وانما نستخدم الوحدة النمطية لاستعمالات اوسع dbx2.rar

البرنامج يحتوي على كائن عنصر Actevix وهذا الكائن بحاجة الى مكتبة خارجية ( برنامج او تعريف) جرب تشغله على اصدارات احدث من اوفيس يمكن انها تشتمل على هذه المكتبة

يمكن ان يكون الحل في هذا الماكرو Option Explicit Sub RASEB_BY_Madda() If ActiveSheet.Name <> "salim (2)" Then Exit Sub Dim My_rg As Range Dim r%, c%, i%, j% Dim Arr_Word() Dim x As Boolean ReDim Arr_Word(1 To 4) Arr_Word(1) = "أقل من 30%": Arr_Word(2) = "دون المستوى": Arr_Word(3) = "غائب": Arr_Word(4) = "غ" ''''''''''''''''''''' Set My_rg = ActiveSheet.Range("b7").CurrentRegion r = My_rg.Rows.Count: c = My_rg.Columns.Count Set My_rg = My_rg.Offset(1, 1).Resize(r - 1, c - 1) My_rg.Columns(c - 1).ClearContents '======================== For i = 1 To r For j = 2 To c Step 2 If My_rg.Cells(i, 1) = vbNullString Then Exit For x = IsError(Application. _ Match(My_rg.Cells(i, j), Arr_Word, 0)) If Not x Then My_rg.Cells(i, c - 1) = "Raseb" Exit For Else My_rg.Cells(i, c - 1) = "Najeh" End If Next Next Erase Arr_Word End Sub الملف مرفق Raseb 2 _with_condition.xls

بعد اذن اخي شريف هذا الكود بنسخ لك الصف في اي خلية تم تحديدها (ليس من الضروري الاولى) ولا تتم عملية النسخ الا اذا كان الصف مكتملاً (من اجل اكمال تعبئة الجدول) Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False Dim Final_Row%, r% Dim my_rg As Range Dim Rg_to As Range: Set Rg_to = Range("i2:k2") Final_Row = Cells(Rows.Count, 1).End(3).Row Set my_rg = Range("a" & 2, "c" & Final_Row) If Not Intersect(Target, my_rg) Is Nothing _ And Target.Count = 1 Then r = Target.Row If Application.CountA(Cells(r, 1).Resize(1, 3)) = 3 Then Rg_to.ClearContents Rg_to.Value = Cells(r, 1).Resize(1, 3).Value End If End If Application.EnableEvents = True End Sub الملف مرفق نقل محتويات salim.xlsm

أخي الكريم نايف إليك الكود التالي عله يكون المطلوب Sub Test() 'تعريف المتغيرات Dim Ws As Worksheet, Sh As Worksheet, Cel As Range, LR As Integer 'تعيين قيمة للمتغير ليساوي ورقة العمل المراد الترحيل منها Set Ws = Sheets("mm") 'تعيين قيمة للمتغير ليساوي ورقة العمل المراد الترحيل إليها Set Sh = Sheets("nn") 'تعيين الخلية التي سيتم ترحيل قيمتها Set Cel = Ws.Range("A1") 'تحديد أول خلية فارغة في العمود الأول في الورقة المراد الترحيل إليها LR = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 'شرط لاختبار تكرار القيمة باستخدام دالة العد بشرط 'فإذا كان ناتج العد أكبر من أو يساوي 1 ، فذلك يعني أن القيمة موجودة If Application.WorksheetFunction.CountIf(Sh.Columns(1), Cel.Value) >= 1 Then 'طالما أن القيمة موجودة تظهر رسالة تفيد بأن القيمة مكررة MsgBox "القيمة مكررة في العمود", 64 Else 'إذا لم تكن القيمة موجودة من قبل في الورقة المراد الترحيل إليها 'يتم وضع القيمة في أول خلية فارغة في العمود الأول بعد آخر خلية بها بيانات Sh.Range("A" & LR).Value = Cel.Value End If End Sub تقبل تحياتي

أخي الكريم الأمير هشام إليك هذا الفيديو قم بتنفيذ الإعدادات مرة واحدة وستتخلص من تلك الرسائل

صحيح Esc = 27