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

Sub test() Dim a, x Dim i&, ii& Application.ScreenUpdating = False a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1 If Not .exists((Cells(i, ii).Value)) Then Cells(i, ii).Interior.Color = vbRed Else Cells(i, ii).Interior.Color = 16777164 End If Next: Next End With Application.ScreenUpdating = True End Sub Sub tes2() Dim a, x x = Cells(1, 9).CurrentRegion.Columns.Count Dim i&, ii& Application.ScreenUpdating = False With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1 If Not .exists((Cells(i, ii).Value)) Then Cells(i, ii).Interior.Color = vbYellow Else Cells(i, ii).Interior.Color = 16777164 End If Next: Next End With Application.ScreenUpdating = True End Sub

أعتقد تأمين الخلايا في الصفحات لا يمنع البحث فيها إلا إذا ألغيت تحديد الخلايا المؤمنة في شاشة الحماية لذا يجب وضع علامة صح بجانب الاختيار الأول select locked cells / تحديد الخلايا المؤمنة حتى يمكن البحث في الصفحة رغم الحماية بالتوفيق

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

يمكنك استعمال هذه المعالة في D2 =IFERROR(IF(MATCH(C2,'العملاء المتوفين'!$C$2:$C$1000,0),"نعم"),"لا") أو =IF(COUNTIF('العملاء المتوفين'!$C$2:$C$1000,C2)>0,"نعم","لا") بالتوفيق

Sub test4() Dim sh As Worksheet: Set sh = Sheets("Sheet1") Lr = sh.Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:N" & Lr) Application.ScreenUpdating = False Set R1 = CreateObject("Scripting.Dictionary") Set R2 = CreateObject("Scripting.Dictionary") For Each J In a R1(J.Value) = J.Value Next J For Each J In b R2(J.Value) = J.Value If Not R1.exists(J.Value) And R2(J.Value) <> "" Then J.Interior.ColorIndex = 36 If R1.exists(J.Value) Or R2(J.Value) = "" Then J.Interior.ColorIndex = xlNone Next J End Sub مقارنة بيانات عمود ببيانات عمود اخر 2.xls او Private Sub Worksheet_Change(ByVal Target As Range) Lr = Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:N" & Lr) With Target Select Case .Column Case 6, 9, 10, 11, 12, 13, 14 If .Row > 1 Then Application.ScreenUpdating = False Application.EnableEvents = False Set R1 = CreateObject("Scripting.Dictionary") Set R2 = CreateObject("Scripting.Dictionary") For Each j In a: R1(j.Value) = j.Value: Next j For Each j In b: R2(j.Value) = j.Value If Not R1.exists(j.Value) And R2(j.Value) <> "" Then j.Interior.ColorIndex = 42 If R1.exists(j.Value) Or R2(j.Value) = "" Then j.Interior.ColorIndex = xlNone Next j Application.EnableEvents = True Application.ScreenUpdating = True End If End Select End With End Sub

الاساتذة الافاضل محمد هشام محى الدين ابو البشر اكرمكم الله بواسع فضله وزادكم من نعمه وفضله وتسلم يداك اخى العزيز محى مجهود رائع .. تقبل شكرى واعتزازى

السلام عليكم اخي زياد انا ماعندي سكنر حاليا 1- لانشاء فولدر انا وضعته عند فتح الموذج pdf Dim xFolder Set xFolder = CreateObject("Scripting.FileSystemObject") If xFolder.FolderExists(CurrentProject.Path & "\archives") = True Then Me.Undo Else 'انشاء مجلد MkDir CurrentProject.Path & "\archives\" End If 2- هذا الكود شغال عندي تمام لاضافة صور او صورة واحدة من الماسح الضوئي اضفت اليه المسار ورقم وتاريخ الكتاب اللي عندك Shell ("c:\Program Files\irfanview\i_view32.exe /batchscan=(" & ID & "_" & Date_Boolk & ",,,,," & temp_scan_path & " ,pdf,1) /scanhidden") جربه واخبرني بالنتيجة

على الرغم انى لم اعمل مثل هذا من قبل لكن اتفضل هذه محاولى هناك الكثير من التعديلات فى الاكواد والجداول والعلاقات عملتها وتم استبدال جميع اكوادك بحلقة تكرارية لكتابة اسماء الازرار وهناك بعض الملاحظات ------------------------------ اولا انت عند خطأ فى العلاقات بين الجداول هذا بعد التعديل على جدول التفاصيل وظبط العلاقات بين الجداول والخطأ الثاني تشابه مسمي سعر البيع وسعر المنتج (ولانه ليس له فائدة فقد تم حذفه ) لان هذا تكرار للبيانات ايضا لا تضع حقول محسوبه فى الجداول (العمليات الحسابيه تكون من الاستعلامات والنماذج) يجب ايضا توضيح العلاقة بين النموذج الفرعي والنموذج الرئيسي وهناك اشياء اخري لكن لم يسعفنى الوقت لتوضيحها اترك لك الباقى والنتيجة هي ------------------------- اتمني هذا يكون هو طلبك مرفق الملف كاشير المطاعم و الكافيهات و المحلات التجارية.rar اها كدت ان انسي عند محاولة برمجة زر جديد فى ال 40 زي كل ال مطلوب تعمله تكرر الكود الذى بداخل الصب هذا Private Sub A1_Click() If a1.Caption = "" Then: Exit Sub xCMD "A1" End Sub مثل تريد برمجة زر رقم a20 يبقى هتضيف داخل الصب الخاص به هذا الكود If a20.Caption = "" Then: Exit Sub xCMD "A20" وهكذا

حسب فهمي للمطلوب يمكنك استعمال هذه المعادلة في الخلية AE5 مع نسخها يسارا =IF(AE4="","", IF(AE4>30,if(COUNTIF($AE$4:AE4,">"&30)=1,25%,if(COUNTIF($AE$4:AE4,">"&30)=2,50%,if(COUNTIF($AE$4:AE4,">"&30)=3,75%,100%))), IF(AE4>15,if(COUNTIF($AE$4:AE4,">"&15)=1,10%,if(COUNTIF($AE$4:AE4,">"&15)=2,15%,if(COUNTIF($AE$4:AE4,">"&15)=3,25%,50%))), if(COUNTIF($AE$4:AE4,"<="&15)=1,5%,if(COUNTIF($AE$4:AE4,"<="&15)=2,10%,if(COUNTIF($AE$4:AE4,"<="&15)=3,20%,20%))) ))) مع تغيير تنسيق الخلايا لهذا الصف نسبة مئوية percentage بالتوفيق

عليكم السلام ورحمة الله وبركاته إذا كان المقصود عدد أيام المكافأة فيمكنك حسابها بهذه المعادلة =IF(C7/360>5,75+(CEILING(C7/360,1)-5)*30,CEILING(C7/360,1)*15) وإذا كان المقصود حساب مكافأة هذه الأيام بناء على راتب الشهر المكتوب يمكنك استعمال هذه المعادلة =IF(C7/360>5,75+(CEILING(C7/360,1)-5)*30,CEILING(C7/360,1)*15)*C3/30 بالتوفيق

تفضل اخي الكريم مثال بسيط Try 2023 PDF.accdb لا تنسى ، اذا انتهت المشكلة ولله الحمد ، فقط اختر الإجابة كأفضل إجابة

هذا مرفق بسيط تفضل Try 2023.accdb لا تنسى ، اذا انتهت المشكلة ولله الحمد ، فقط اختر الإجابة كأفضل إجابة

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

بارك الله فيك أخي نعم هو المطلوب وانحلت المشكلة الظاهرة لدي وجزاك الله خيرا خالص الشكر والتقدير لك أخي وبارك الله فيك على مساعدتك لي والشكر موصول للاخوة الآخرين المشاركين معنا في الموضوع بحمد الله بعد تعديل الاخ الكريم murady اصبح الملف يعمل معي بشكل جيد طبعا لا أنسى أن الفضل يعود بعد توفيق الله الىك أخي @ناقل وعلى استمرارية تواصلك معي .. شكرا لكم وبارك الله فيكم

استاذ @ابو الريم علشان في بعض المعادلات لا تستوي بالجدول بتحصل كل طلباتك بالاستعلام1 ومبين ذلك بالفورم1. RAMI-1.accdb

الاستاذ الفاضل محي الدين اسئل الله ان يبارك الله في علمك ويطول بعمرك واشكرك كثيراً على هذا الحل الاخر تحياتي لك اخي الحبيب

السلام عليكم اخى الفاضل frqd لو كان موضوع الحدود هو المشكلة فأرجو أن يكون كما عدلت إليك التعديل Database1 (23).accdb

وعليكم السلام ورحمة الله وبركاته اعتقد ان طلبك ليس له حل لو كان لحمايه ورقه العمل فالاكواد موجوده كثيره في المنتدى

ربما يرجع السبب لعدم ضبط اعدادات اللغة العربية في الويندوز مع تمكين المحتوى طبعا في بداية فتح الملف بالتوفيق

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

جزاكم الله خبرا بتقول انت تعبت في عمل الاكواد ومش عايز واحد ياخد اي كود طيب ممكن تكتب كود واحد من تصميمك هنا ولا تم اخد الاكواد من المنتديات وتطويعها لك وخايف حد يشوف انك اخدتها منهم ... مجرد سؤال عايزين العلم ينتشر الله يرحم والديك ووالدينا

وعليكم السلام ورحمة الله تعالى وبركاته المشكلة ليست في الحل اخي سعد طلبك ليس بالسهل يجب ان تعلم ان عكس اظهار البيانات على الليست بوكس يتطلب تعديل اكواد الترحيل والتعديل والحذف ...وهدا يلزمه بعض الوقت . Dim Col(), WSData, Largeur(), MyRng, ligne, F, ColSearch(), J Private Sub UserForm_Initialize() Dim A, B, C, D ' اسماء الجداول A = [Tableau1]: B = [Tableau2]: C = [Tableau3]: D = [Tableau4] ' التعامل مع ورقة العمل النشطة Set WSData = ActiveSheet ' نطاق البيانات Set MyRng = WSData.Range("C10:M" & WSData.[C65000].End(xlUp).Row) F = WSData.Range("C10:M" & WSData.[C65000].End(xlUp).Row).Value ' ترتيب الاعمدة الظاهرة على الليست بوكس Col = Array(11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1) ' عرض الاعمدة Largeur = Array(60, 50, 60, 80, 65, 75, 75, 80, 170, 50, 15) Me.ListBox2.ColumnCount = UBound(Col) + 1 Me.ListBox2.ColumnWidths = Join(Largeur, ";") ' اظهار البيانات على الليست بوكس On Error Resume Next Me.ListBox2.List = Application.Index(MyRng, Evaluate("Row(1:" & MyRng.Rows.Count & ")"), Col) On Error GoTo 0 'اعمدة خاصة بفلترة الليست بوكس ColSearch = Array(11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1) ' تم تحديد عمود اسم الطالب (يمكنك تعديله) J = UBound(ColSearch) + 1 'عناوين الليست بوكس Transférer Me.ListBox1.Visible = False Me.Show_file.Caption = "إظهار ملف العمل" ' رقم الصف ligne = WSData.[C65000].End(xlUp).Row + 1 Me.N_Row = ligne ' عدد الصفوف على الجداول NbLigne = [Tableau1].Rows.Count + [Tableau2].Rows.Count + [Tableau3].Rows.Count + [Tableau4].Rows.Count If Me.ComboBox1.Value = Empty Then Counter.Caption = "المجموع" & " / " & NbLigne Else Counter.Caption = Me.ComboBox1.Text & " / " & ListBox2.ListCount + 0 End Sub '******************************* Sub Transférer() On Error Resume Next i = 0 For Each C In Col i = i + 1 Me("MH" & i).Caption = MyRng.Offset(-1).Item(1, C) Next End '****************************** Sub Search() students_name = "*" & Me.TextBox12 & "*" Dim Tbl(): n = 0 For i = 1 To UBound(F) If F(i, 3) Like students_name Then ' فلترة باسم الطالب n = n + 1: ReDim Preserve Tbl(1 To J, 1 To n) C = 0 For Each k In ColSearch C = C + 1: Tbl(C, n) = F(i, k) Next k End If Next i If n > 0 Then Me.ListBox2.Column = Tbl Else Me.ListBox2.Clear End Sub محمد_3.xlsm

iif(isnull([a]),0,[a])+iif(isnull([m]),0,[m])+iif(isnull([f]),0,[f])+iif(isnull([c]),0,[c])+iif(isnull([d]),0,[d]) مع الانتباه الى تغيير الفاصلة الى فاصلة منقوطة اذا كانت النسخة لديك عربية بالتوفيق