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

اعمل استعلام وضع فيه هذا مع تعديل اسم الحق الذي به المبلغ واسم الجدول لديك 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;

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

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

السلام عليكم مشاركه مع اخى واستاذى محمد البرناوى اخى محمد حلك جميل ولكن بالنسبه للفقره الاول انت اختبرت المبلغ لو اقل ومع امثله الاستاذ الفاضل هو عاوز المبلغ اللى اكبر يتم طرحه يعنى مث ما هو موضح بالمثال بالاعلى 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.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 الاقسام قسم الأكسيس  

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

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

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

هذا اذا استعملت الكود كاملا !! رجاء انظر الى الرابط الذي وضعته في مشاركتي الاولى ، وهذا كود عمل Vcard الموجود هناك ، ولكني استعملت حقول الاسم الاول ومكان العمل ورقم الهاتف وتاريخ الميلاد فقط ، واوفقت الباقي (بهذه الطريقة انت اختار الحقل اللي تريدها) : Function Add_Items() Dim VCard_Text As String 'clear field VCard_Text = "" VCard_Text = "BEGIN:VCARD" & vbCrLf VCard_Text = VCard_Text & "VERSION:3.0" & vbCrLf ' VCard_Text = VCard_Text & "N:" & Me.[Family Name] & ";" & Me.[Given Name] & ";" & Me.[Additional Name] & ";" & Me.[Name Prefix] & ";" & vbCrLf VCard_Text = VCard_Text & "FN:" & Me![Name] & vbCrLf VCard_Text = VCard_Text & "ORG:" & Me.[Organization 1] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 1 - Type] & ",VOICE:" & Me.[Phone 1 - Value] & vbCrLf ' VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 2 - Type] & ",VOICE:" & Me.[Phone 2 - Value] & vbCrLf ' VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 3 - Type] & ",VOICE:" & Me.[Phone 3 - Value] & vbCrLf ' VCard_Text = VCard_Text & "ADR;:" & ";;" & Me.[Address 1] & ";;;;" & vbCrLf VCard_Text = VCard_Text & "BDAY:" & Me.[Birthday] & vbCrLf ' VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 1 - Type] & ":" & Me.[E-mail 1 - Value] & vbCrLf ' VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 2 - Type] & ":" & Me.[E-mail 2 - Value] & vbCrLf ' VCard_Text = VCard_Text & "NOTE:" & Me.Notes & vbCrLf ' VCard_Text = VCard_Text & "URL:" & Me.[Website 1] & vbCrLf VCard_Text = VCard_Text & "END:VCARD" Add_Items = VCard_Text End Function

السللام عليكم التغيير من السبنر المرتبط بالخلية J2 ثانوية عامة.xlsm

أعتذر لك لضيق وقتي. لعل أحد الأاساتذه يفيدك لأن المطلوب يستغرق وقت

وعليكم السلام ورحمة الله وبركاته جرب الكود ويوضع في THISWORKBOOK Private Sub Workbook_Open() Dim ws As Worksheet Application.DisplayFullScreen = True Application.DisplayFormulaBar = False For Each ws In ThisWorkbook.Worksheets ws.Activate With ActiveWindow .DisplayHeadings = False .DisplayGridlines = False End With Next ws End Sub

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

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

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

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

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

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

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

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

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

تفضل بالتوفيق الرقم القومى.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

بارك الله فيك لا اعرف كيف يتم الشكر لهذا الجود من استاذنا / عبدالله بشير بارك الله في عمرك

حسب فهمي لسؤالك في الكود المعدل الكود يقرأ عمود التاريخ كرقم وللتوضيح اكثر التواريخ هي في الأصل أرقام (مثلاً تاريخ اليوم هو رقم مثل 46040)، والتنسيق الذي تراه dd/mm/yyyy هو مجرد "قناع" أو مظهر خارجي لتسهيل القراءة علينا كبشر. في الكود توجد الدالة CDbl(.Range("J3").Value)، بحيث يأحد "القيمة الرقمية" الحقيقية المخزنة داخلها. وباحتصار الكود الآن يرى التاريخ كقيمة رقمية مجردة، بغض النظر عن طريقة تنسيق التاريخ في خلايا الجدول (سواء كانت yyyy/mm/dd أو dd-mm-yy). ويمكنك تجربة تبديل بعض التواريح بتغيير التنسيق في الجدول كمثال جعل 15/04/2026 الى 04/15/2026 فالنتيجة واحدة تحياتي

بارك الله فيك وجزاك الله خير الجزاء إجابتك ليست حل للمشكلة بل توصيف لمكمن الخطأ حتى نتفاداه في أيامنا المقبلة جزيل الشكر لك أخ عبدالله 🌹

سلمت يمينك استاذنا الغالي .. وشكراً جزيلاً لسعة صدرك 🌹🌹

ثانوية عامة2.xlsm

وعليكم السلام ورحمة الله وبركاته .. السبب طريقة ترميز الـ QR نفسه + سياسة iOS في التعامل معه . و طبعاً كاميرا الآيفون ذكية أكثر من اللازم .

عليكم السلام الامر يسير .. انظر في المرفق وانظر في التقرير الخطوات : من خصائص حقل ID لسان التبويب : بيانات - جعل مصدر حقل ID هو : (=1) - انظر الخاصية في التجميع = Over All نضع هذه الخاصية اذا اردنا الترقيم مستمر .. ونختار الأخرى Over Group اذا اردنا الترقيم حسب المقاطع test2.rar

شوف الافكار هنا بها تحقيق طلبك تماما وبدون تخزين محافظة الميلاد ولا تاريخ الميلاد ولا السن حتى داخل الجدول Test.accdb

بارك الله بك استاذي الكريم شكرا جزيلا على الإجابة... شكرا جزيلا استاذي الفاضل على التذكرة تم التصحيح...

تفضل استاذ @figo82eg طلبك بالاستعلام Query1 .ووافني بالرد . New Microsoft Access Database-111.rar

بارك الله فيك أخي الفاضل خليفة وزادك الله من علمه وجعلك من المصطفين الأخيار معلش أنا بتعبك دائما معي

كورس بل مدرسة كاملة للتعامل مع مربعات قوائم أكسس البليدة الصامتة شكرا على هذا العمل الجميل الرائع

جرب Round((([درجة1]+[درجة2]+[درجة3]+[درجة4])/4)*2)/2 لو فى استعلام AvgRounded:Round(((Nz([Exam1],0)+Nz([Exam2],0)+Nz([Exam3],0)+Nz([Exam4],0))/4)*2)/2 بالتوفيق

حسنا دعني ارى ما يمكنني عمله

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

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

وعليكم السلام ورحمة الله وبركاته .. بدايةً اسم الحقل = "id_pers" وليس "رقم التسجيل" صحيح ؟؟ اعتقد انك تستطيع استعمال الدالة DMAX كقيمة افتراضية لمربع النص داخل النموذج . كمثال ، اجعل القيمة الإفتراضية لمربع النص id_pers تساوي الجملة التالية وجرب بعد أن تقوم بحذف السجل الموجود في جدولك :- =Nz(DMax("id_pers","tbl_personne1"),19020999)+1 ملفك بعد التعديل :- IsertImages.zip

اليوم اقدم لكم أضخم كتاب عربي لتعلم برنامج EXCEL يحتوي على شرح مفصل لصيغ والدوال وكذالك مرفق مع الكتاب تطبيقات نموذجية . غلاف الكتاب المحتويات 1.بداية الكتاب معلومات اساسية عن برنامج إكسل 2007 2. استخدام الدالات في الصيغ 3. شرح كافة المعادلات في والتطبيق في إكسل 4. شرح صيغ الصفيف وأمثلتها المستحيلة في إكسل 5. شرح جداول Pivot والمراجع الدائرية المقصودة والمخططات والرسوم البيانية والتنسيق الشرطي والادوات والتنقيح 6.في النهاية الغير متوقعة شرح لغة VBA وطريقة كتابة الصيغ فيها لتحميل الكتاب اضغط هنا حجم الكتاب: 39.7 MB رابط اخر على 4shared أرجو الدعاء لي ولصاحب الكتاب وناشره جزاكم الله خيرا

اخي الكريم ابو أحمد السلام عليكم ورحمة الله وبركاته تم ضبط كود شهر نوفمبر بالمرفقات مع تحياتي Charts Form.rar