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

اعمل استعلام وضع فيه هذا مع تعديل اسم الحق الذي به المبلغ واسم الجدول لديك SELECT Amount, IIf([Amount] <= 15000, [Amount] * 0.1, 15000 * 0.1) AS [10%], IIf([Amount] > 15000, ([Amount] - 15000) * 0.15, 0) AS [15%] FROM YourTableName;

السلام عليكم مشاركه مع اخى واستاذى محمد البرناوى اخى محمد حلك جميل ولكن بالنسبه للفقره الاول انت اختبرت المبلغ لو اقل ومع امثله الاستاذ الفاضل هو عاوز المبلغ اللى اكبر يتم طرحه يعنى مث ما هو موضح بالمثال بالاعلى 21000 هتكون 15000 *0.1 والباقى اللى هو 6000 *0.15 Option Compare Database Function calc(val As Double, Optional colVal = "") Const val_15 = 15000 Dim bak If colVal = 10 Or colVal = 0.1 Or colVal = "" Then colVal = 0.1 ElseIf colVal = 15 Or colVal = 0.15 Then colVal = 0.15 End If If val <= val_15 Then calc = val * colVal If val > val_15 Then bak = val - val_15 val = val_15 End If If colVal = 0.1 Then calc = val * colVal ElseIf colVal = 0.15 Then calc = bak * colVal Else calc = 0 End If End Function وتقبلوا مشاركتى ومرورى واحبكم فالله

وعليكم السلام ورحمة الله وبركاته جرب الكود حيث قبل التنفيذ، يقوم بحذف أي دوائر سابقة 1الثالث.xlsb

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

وجب الاعتذار من اخى واستاذى لعدم انتباهى للجزء الثانى من الشرط

تفضل اختر ما يناسبك دمج مبلغ1.xlsx

السلام عليكم جرب الكود Sub تلوين_المكرر() Dim ws As Worksheet, rng As Range, cell As Range Dim dict As Object, lastRow As Long Dim r As Long, c As Long, key As String Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then lastRow = 5 Set rng = ws.Range("A5:J" & lastRow) rng.Interior.ColorIndex = xlNone Application.ScreenUpdating = False For r = 5 To lastRow For c = 1 To 10 Set cell = ws.Cells(r, c) If Not IsError(cell.Value) And Len(cell.Value) > 0 Then key = Trim(cell.Value) Set dict = CreateObject("Scripting.Dictionary") For Each c2 In ws.Range(ws.Cells(r, 1), ws.Cells(r, 10)) If c2.Value = key Then dict(key) = dict(key) + 1 Next If dict(key) > 1 Then cell.Interior.Color = vbRed: GoTo NextCell ' التحقق عموديًا dict.RemoveAll For Each r2 In ws.Range(ws.Cells(5, c), ws.Cells(lastRow, c)) If r2.Value = key Then dict(key) = dict(key) + 1 Next If dict(key) > 1 Then cell.Interior.Color = vbRed End If NextCell: Next c Next r Application.ScreenUpdating = True End Sub

اعرض الملف إجعل مربع القائمة يتناسق مع بقية تنسيقات النموذج بإستخدام أداة مربع القائمة المخصص {سلسلة الأدوات المساعدة المخصصة} كما يعلم الجميع فإن عنصر التحكم (مربع القائمة) القياسي من عناصر التحكم التي لاتمنحنا خيارات أوسع في التنسيق كمحاذاة النص أو تغيير لون الخط أو لون التحديد وغيرها من التنسيقات التي تجعله يتماشى مع بقية عناصر التحكم بإستخدام هذه الأداة سنحصل على مربع قائمة مخصص يقوم بمنحنا خيارات تنسيق واسعة مرفق لكم مجلد يحتوي على - نسخة توضيحية لوظائف الأداة (أرجو أن يتم فتح هذا الملف في البداية) - مستند وورد يحتوي على تعليمات (يرجى قرائتها بتركيز وتطبيق الخطوات كما وردت) يحتوي هذا المستند في نهايته على تلميحات مهمة ستساعدكم في حال ظهور بعض الأخطاء أثناء العمل - نسخة بإسم القالب والتي وكما تعودنا بأنها ستحتوي على الكائنات الضرورية لعمل الأداة - ملف مضغوط يحتوي على نسخة تدريبية ليتم تطبيق الخطوات الواردة في التعليمات عليها الملاحظة التي أود تقديمها هنا أنه في البداية قد يواجه البعض صعوبة في العمل مع الإداة والذي يمكن تجاوزها بقراءة وتنفيذ التعليمات أكثر من مرة لذلك تم وضع النسخة التدريبية في ملف مضغوط حتى يمكنكم الحصول على نسخة فارغة جديدة في حال أردتم إعادة تطبيق التعليمات للتدرب تحياتي صاحب الملف منتصر الانسي تمت الاضافه 01/09/26 الاقسام قسم الأكسيس  

و عليكم السلام ورحمة الله وبركاته __اصناف مشتريات - نسخة2.xlsx

وعليكم السلام ورحمة الله وبركاته جرب الكود في الملف المرفق 1الجرد.xlsm

لدي هذا التطبيق يقوم باختبارات ادارية متنوعة ارجو ان تبدو رأيكم فيه مع جزيل الشكر Administrative_Tests.rar

تجسيداً لفكرة التعامل مع التقرير .. هذه الفكرة المبدأية لشكل التقرير عند فتحه بعد حفظ التصميم ، وتصديره الى ملف PDF .. مسارات ومواضع العناصر في الفيديو تم تجربتها مسبقاً . لذلك هي معروفة لي .

ممكن يكون طلبك هنا https://www.youtube.com/watch?v=M1DhpzkT8kA او جرب هذا الكود: Sub Observer_FullSystem() Dim ws As Worksheet, wsReport As Worksheet Dim NamesArr() As Variant Dim UsedRow As Object, UsedCol As Object, UsedAll As Object Dim lrNames As Long, lrRows As Long, lrCols As Long Dim r As Long, c As Long, i As Long Dim Available() As String Dim cnt As Long, MaxAllowed As Long, TotalCells As Long Dim TryCount As Long Dim MainCols As Long: MainCols = 2 ' عدد الأعمدة الأساسية Set ws = ActiveSheet Application.ScreenUpdating = False Randomize ' ===== Backup ===== ws.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "Backup_" & Format(Now, "ddmmyy_hhmmss") ws.Activate ' ===== قراءة الأسماء ===== lrNames = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row NamesArr = ws.Range("B3:B" & lrNames).Value ' ===== حدود الجدول ===== lrRows = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row lrCols = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)).ClearContents ' ===== الحد الأقصى ===== TotalCells = (lrRows - 2) * (lrCols - 3) MaxAllowed = Application.WorksheetFunction.RoundUp(TotalCells / (lrNames - 2), 0) Set UsedAll = CreateObject("Scripting.Dictionary") ' ===== التوزيع ===== For r = 3 To lrRows Set UsedRow = CreateObject("Scripting.Dictionary") For c = 4 To lrCols TryCount = 0 RetryCell: TryCount = TryCount + 1 If TryCount > 300 Then GoTo NextCell Set UsedCol = CreateObject("Scripting.Dictionary") For i = 3 To r - 1 If ws.Cells(i, c).Value <> "" Then UsedCol(ws.Cells(i, c).Value) = 1 Next i cnt = 0 ReDim Available(1 To UBound(NamesArr, 1)) For i = 1 To UBound(NamesArr, 1) If Not UsedRow.exists(NamesArr(i, 1)) _ And Not UsedCol.exists(NamesArr(i, 1)) Then If Not UsedAll.exists(NamesArr(i, 1)) _ Or UsedAll(NamesArr(i, 1)) < MaxAllowed Then cnt = cnt + 1 Available(cnt) = NamesArr(i, 1) End If End If Next i If cnt > 0 Then ws.Cells(r, c).Value = Available(Int(Rnd * cnt) + 1) UsedRow(ws.Cells(r, c).Value) = 1 UsedAll(ws.Cells(r, c).Value) = UsedAll(ws.Cells(r, c).Value) + 1 Else GoTo RetryCell End If NextCell: Next c Next r ' ===== تقرير ===== On Error Resume Next Set wsReport = Sheets("تقرير") On Error GoTo 0 If wsReport Is Nothing Then Set wsReport = Sheets.Add wsReport.Name = "تقرير" Else wsReport.Cells.Clear End If wsReport.Range("A1:D1") = Array("الاسم", "الإجمالي", "أساسي", "احتياطي") For i = 3 To lrNames wsReport.Cells(i - 2, 1) = ws.Cells(i, 2) wsReport.Cells(i - 2, 2) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 3) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, 3 + MainCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 4) = wsReport.Cells(i - 2, 2) - wsReport.Cells(i - 2, 3) Next i wsReport.Columns.AutoFit Application.ScreenUpdating = True MsgBox "تم التوزيع + إنشاء نسخة احتياطية + تقرير كامل ?", vbInformation End Sub

و عليكم السلام ورحمة الله وبركاته تفضل الملف بالأكواد. أما إذا كنت لا تفضل الأكواد فالحل بسيط وسهل باستخدام التصفية في العمود الموجود به الحاله حذف و إظهار صف بشرط.xlsm

السلام عليكم حقيقة الدحول الى الموقع اصبح بالصدفة قليل ما تجدة يعمل الكود سليم والمشكلة في تنسيق الأرقام قي صفخة table في العمودين b& e اذا اردتها بالأرقام العربية حسب ملفك فقم بتنسيقها الى [$-,201]# وان اردتها بالأرقام الغربية اجعل النتسيق رفم بدون خانات عشرية ملف بتنسيق الارقام العربية [$-,201]# مراقبة ثانوية 2026.xlsm ملف بتنسيق الارقام الغربية مراقبة ثانوية1 2026.xlsm

المصدر هو الاستعلام والتعديل في الاستعلام .. بدل اخذ Nr من جدول TblDetaché تم اخذه من جدول tbl_Loans

توزيع رقم على خلايا.xlsm

و عليكم السلام ورحمة الله و بركاته الموضوع سهل جدا من خلال عمل فلترة الموجودة في اكسيل كما هو واضح بالصور. ممكن تستخدم أيا من الملفين واحد بالأكواد و الثاني بالصيغ بس لا يصلح إلا أوفيس 365 أو 2021 فلترة.7z

تفضل الملف باستخدام الصيغ مع عمل تنسيق شرطي للتأكد من التكرار كشاف دخول اللجان2.xlsm

وعليكم السلام ورحمة الله وبركاته InputBox في VBA لا يدعم إخفاء النصوص أو إظهارها كنجوم بشكل مباشر. الحل هو استخدام UserForm مع TextBox خاصية PasswordChar طباعة.xlsm

الاسهم في ملفك لم تشمل الاحتياطي اليك الملف تكملة1 مراقبة 2026.xlsm

اذا كنت تقصد عمل كلمة مرور للزر في الفورم يمنع الدخول الى ملف الاكسل اليك طلبك كلمة المرور 1234 يمكنك تعديلها من الكود طباعة2.xlsm

وعليكم السلام ورحمة الله وبركاته ،، جرب هذا التعديل الذي تم على الجمل الشرطية داخل الاستعلام عند التوزيع .. لجان الامتحانات.zip

تفضل استاذ @figo82eg طلبك حسب ما فهمت . ووافني بالرد . الرقم القومى-1.rar

تفضل بالتوفيق الرقم القومى.rar

👿 !!! ؟؟

السلام عليكم ورحمة الله وبركاته اقدم لكم شرح مبسط لطريقة بحث احترافيه في شيت اكسل رابط الفيديو لتحميل ملف العمل https://www.mediafire.com/file/4t7skm26bdj2mhk/salloum.xlsx/file

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

اعلم هذا وواضح بالملف وعملت في قطاع التعليم التقني والتوجيه الفني 39 سنة واعلم جيدا كيف عمل اللجان لم يكن الامر يتطلب كل هذا على كل حال عودة للملف اليك الملف بالتعديل الاخير مراقبة_ تحويل اللجان الى أسماء.xlsm

اليك ما طلبت بالتنسيق الشرطي aaaa2.xlsm

دائما لك نكهة خاصة مميزة 😋👌🌹 إبداع وإمتاع

استاذ بارك الله فيك شكرا جزيلا

تفضل استاذ @basem1978 طلبك حسب ما فهمت . ووافني بالرد . 1 (1).rar

صدقت وعفوا وشكرا على التنبيه

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

تم عمل بعض التعديلات عمي جعفر .. مع التنويه إلى أن هذه الأداة لاتقوم بكتابة الأكواد بناءً على الطلبات ! بل وظيفتها تعديل وتحسين الكود الذي تعطيها إياه وتصحيح الأخطاء الموجودة فيه بالإضافة للخدمات الأخرى : ولتحقيق مرونة أكبر للمستخدم ، أضفت حقل خاص بكتابة تعليمات مخصصة توجهها للذكاء الاصطناعي بحيث يراعيها عند معالجة الطلب ، مثال : ( قم بتغيير أسماء المتغيرات لأسماء مقروءة ، أو قم تقسيم جملة SQL لعدة أسطر هكذا ....... ، أو ، أو ) أكتب ما شئت 🙂 وبعد التجربة على الجملة التي أوردتها : strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " & vbCrLf & _ "FROM tblCheckINOut " & vbCrLf & _ "WHERE (((tblCheckINOut.EmpUser)='" & EmpUserid & "')) " & vbCrLf & _ "ORDER BY tblCheckINOut.id DESC;" كانت النتيجة : Option Explicit Dim strSql As String strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " strSql = strSql & "FROM tblCheckINOut " strSql = strSql & "WHERE (((tblCheckINOut.EmpUser)='" & EmpUserid & "')) " strSql = strSql & "ORDER BY tblCheckINOut.id DESC;" وكانت هذه هي التعليمات الإضافية : قم بتقسيم جملة SQL لعدة أسطر بهذا الأسلوب : strSql = strSql & " "

ما شاء الله تبارك الله افكار مبدع اخي @Foksh فكرة اضافية لعمل سابق لي مشابه لفكرتك اضف بالاضافة الى النص والصورة .... اضف اختيار حقل من جدول ... لان الشهادات عادة يصعب كتابة كل شهادة على حده ... بل تأخذ البيانات من جدول مثلا ... بارك الله فيك وفيما تقدم من افكار جميلة للمنتدى وتثري افكار من يمر بالموضوع ....

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

استاذي ابو خليل . فقط للمشاركة ....... أثناء التوقف . كنت اتسلى بعمل هذا المرفق . طالعهه يمكن يفيدك منه شئ . BoKhalil.rar

تفضل استاذ @Emad.85 المرفق بطلبك ووافني بالرد . Emad.85.rar

البرنامج ممتاز ... ولكن عند تشغيلة يظهر بهذه الصورة زاحفا نحو اليسار الى الاسفل يبدو بسبب هذا الكود عند الفتح Private Sub Form_Current() Me.Form.InsideHeight = 9000 Me.Form.InsideWidth = 17000 CenterFormOnScreen "frm-UserLogon" End Sub

هل الملف كان يعمل ثم فجأة توقف؟ ارسل الملف للاصلاح .

بارك الله فيك .. وللمرة المليون أسف على تعب حضرتك وجعله في ميزان حضرتك ... وهذا أملنا في هذا المنتدى العظيم بأساتذته

شكراً لك معلمي الفاضل 🤗.. إن شاء الله جاري العمل على التنفيذ بحيث يتم الإخراج من خلال تقرير، ولكن بعد الإنتهاء من بعض التعديلات بحيث سيتم اسناد جدول او استعلام كمصدر سجلات للتقرير ، مع ضم مربعات النص الي حقول بدلاً من الإدخال اليدوي للبيانات المتغيرة مثل الاسم او الدرحة ..... الخ . مع إتاحة التصدير كملف PDF طبعاً . وغيرها من الإضافات 😇 .

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

وعليكم السلام ورحمة الله وبركاته جرب هذا تسلسل ملئ بيانات الفورم1.xlsm

رداً على هذه النقطة ، وحيث أنه سبق تنفيذها سابقاً .. جرب المرفق نفسه بعد التعديل بحيث سيتم فقط عرض الخطوط العربية ( أو التي تتعامل مع الكاركتر العربي ) في الكومبوبوكس . مع إضافة الفرز التصاعدي للأسماء :- Db3.zip

تفضل جرب اخي ووافينا بالنتيجة Sub RefreshData() ' تعديل Dim i As Long, k As Long Dim last_Dest As Long, lastrow As Long Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each ws_dest In ThisWorkbook.Worksheets lastrow = ws_data.Cells(ws_data.Rows.Count, 1).End(xlUp).row last_Dest = ws_dest.Cells(ws_dest.Rows.Count, 1).End(xlUp).row Application.ScreenUpdating = False For i = 2 To lastrow For k = 2 To last_Dest 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If ws_dest.Name <> ws_data.Name And ws_dest.Name <> "اليومية" And ws_dest.Name <> "ورقة6" Then ' شرط تطابق عمود التسلسل وعمود التوجيه If ws_dest.Cells(k, 1).Value = ws_data.Cells(i, 1).Value And _ ws_dest.Cells(k, 2).Value = ws_data.Cells(i, 2).Value Then _ 'في حالة تحقق الشرط ws_dest.Cells(k, 3).Value = ws_data.Cells(i, 3).Value 'التاريخ ws_dest.Cells(k, 4).Value = ws_data.Cells(i, 4).Value ' البيان ws_dest.Cells(k, 5).Value = ws_data.Cells(i, 5).Value 'مدين ws_dest.Cells(k, 6).Value = ws_data.Cells(i, 6).Value 'دائن ws_dest.Activate 'تسطير تلقائي للبيانات DL = ws_dest.Range("A65500").End(xlUp).row DC = ws_dest.Cells(1, Columns.Count).End(xlToLeft).Column ws_dest.Columns("A:F").Borders.LineStyle = xlNone ws_dest.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If End If Next Next Next ws_dest ws_data.Activate MsgBox "تم التعديل بنجاح", 64 Application.ScreenUpdating = True End Sub Sub transfer_data() ' ترحيل Dim Sh As Worksheet Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each Sh In ThisWorkbook.Worksheets For R = 2 To [B20000].End(xlUp).row If Cells(R, 2).Value = Sh.Name And Cells(R, 2).Value <> Empty Then Application.ScreenUpdating = False Cells(R, 2).Resize(1, 5).Copy Sh.Range("B" & Sh.[B20000].End(xlUp).row + 1) End If Next Next For Each Sh In Worksheets 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If Sh.Name <> "اليومية" And Sh.Name <> "data" And Sh.Name <> "ورقة6" Then Sh.Activate Sh.Range("A3:A1000").ClearContents Sh.Range("A3") = 1 Sh.Range("A3:A" & Range("B" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear DL = Sh.Range("A20000").End(xlUp).row DC = Sh.Cells(1, Columns.Count).End(xlToLeft).Column Sh.Columns("A:F").Borders.LineStyle = xlNone Sh.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If Next MsgBox ("تم بحمد الله ترحيل القيود لا تنسى أن تشكر الله علي هذه النعم "), vbOKOnly + vbInformation, "لاتنسونا من صالح الدعاء لنا ولولدينا وللمسلمين" ws_data.Activate Application.ScreenUpdating = True End Sub استدعاء من عدة شيتات- V3.xlsm