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

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

وعليكم السلام ورحمة الله وبركاته فكرة pdf انه يقوم بانشاء صفحة مؤقتة بها اسماء الموظفين وكل موظف قي ورقة ثم يصدرها الى pdf قم يحذف الورقة عدد الموظفين لديك حوالى 350 موظف بمعنى يتم انشاء حوالى 350 ورقة المقصود مما سبق دكره ان الكود سيأحد بعض الوقت لتنفيذ الامر ويعتمد الامر على مواصفات الجهاز بالنسبة لجهازي تطلب الامر دقيقة ونصف بمواصفات في حدود الجيدة اليك الملف مرتب الفنيين عن شهر يناير 2026 تعديل.xlsm

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

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

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

السلام عليكم جرب الكود 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

هذا افضل فلا يمكن معالجة مشكلة إلا في نفس بيئتها

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

ينفع كذا باش مهندس ؟

تحفيزاً .. سأقوم بطرح فكرتي التي تمت من خلال مجموعة التحديات التي تقام كل فترة بين أعضاء مجموعة "مجتمع آكسيس جروب" على الواتس أب .. التحدي 10 _ التقييم 5 نجوم.zip

السلام عليكم السبب هو وجود مسافات قبل الارقام وهذا يحدث عادة عند نسح ارقام ناتجة عن معادلات الحل كل القيم تتحول إلى نصوص (CStr) وتُزال الفراغات (Trim) وهذا يضمن التطابق حتى لو كانت القيم أرقام أو نصوص أو ناتجة عن معادلات. اليك الكود المعدل Sub تحويل_اللجان_الى_اسماء_Turbo() Dim ws As Worksheet: Set ws = ActiveSheet Dim r As Long, c As Long Dim lastRowMain As Long, lastRowSearch As Long Dim رقم_اللجنة As String, اسم_اللجنة As String, اسم_المراقب As String Dim فارق_الاعمدة As Long: فارق_الاعمدة = 12 Dim cell As Range lastRowSearch = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row ws.Range("P3:X" & lastRowSearch).ClearContents lastRowMain = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastRowSearch = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row For r = 3 To lastRowMain اسم_المراقب = Trim(CStr(ws.Cells(r, "B").Value)) For c = 4 To 12 رقم_اللجنة = Trim(CStr(ws.Cells(r, c).Value)) If رقم_اللجنة <> "" Then For Each cell In ws.Range("C3:C" & lastRowMain) If Trim(CStr(cell.Value)) = رقم_اللجنة Then اسم_اللجنة = Trim(CStr(ws.Cells(cell.Row, "B").Value)) Dim صف_المراقب As Range For Each صف_المراقب In ws.Range("N3:N" & lastRowSearch) If Trim(CStr(صف_المراقب.Value)) = اسم_المراقب Then ws.Cells(صف_المراقب.Row, c + فارق_الاعمدة).Value = اسم_اللجنة Exit For End If Next صف_المراقب Exit For End If Next cell End If Next c Next r End Sub

السلام عليكم حسب قهمي للكود الكود يتعامل مع العمود A والذي به ترقيم والمفترض التعامل مع الاسماء في العمود B اذا كان فهمي للامر صحيح اليك الكود المعدل والا قم بتوضيح الامر اكثر تصوري Sub Compare2() Dim lr As Long, i As Long, j As Long Dim strCol As String Dim WS As Worksheet: Set WS = Worksheets("Data") Dim hasMissing As Boolean: hasMissing = False Application.ScreenUpdating = False On Error Resume Next lr = WS.Columns("B").Find(What:="*", SearchDirection:=xlPrevious).Row On Error GoTo 0 If lr < 6 Then Application.ScreenUpdating = True Exit Sub End If For i = 6 To 18 strCol = Split((WS.Columns(i).Address(, 0)), ":")(0) Dim lastInCol As Long lastInCol = WS.Cells(WS.Rows.Count, strCol).End(xlUp).Row If lastInCol < 6 Then lastInCol = 6 For j = 6 To lr If WorksheetFunction.CountIf(WS.Range(strCol & "6:" & strCol & lastInCol + 500), WS.Range("B" & j)) = 0 Then With WS.Cells(WS.Rows.Count, strCol).End(xlUp).Offset(1) .Value = WS.Range("B" & j).Value End With hasMissing = True lastInCol = lastInCol + 1 End If Next j Next i Application.ScreenUpdating = True End Sub

هذا اذا استعملت الكود كاملا !! رجاء انظر الى الرابط الذي وضعته في مشاركتي الاولى ، وهذا كود عمل 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

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

وعليكم السلام ورحمة الله وبركاته جرب الكود ويوضع في 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 .. مسارات ومواضع العناصر في الفيديو تم تجربتها مسبقاً . لذلك هي معروفة لي .

بحسب الصورة والذي فهمته منها أنه يجب أن يكون عندك 4 قواطر 1 بترول 2 بترول 1 ديزل 2 ديزل ويجب أن يكون القراءة الحالية لأي يوم تساوي السابقة لليوم الذي بعده لا يكون هناك فرق في العدادات والصورة تظهر مشكلة فرق في القاطرة 2 بترول دعني أشرح لك ( وأنت بالتأكيد فاهم شغلك تمام ولكن لازم نفهم نحن شغلك علشان نساعدك في حل المشكلة حسب الصورة تابع معي سلوك القاطرة (مثلا) 1 بترول في يوم 1/10/2025 السابق 500 والحالي 1500 القاطرة قبل تحركها كانت 500 وبعد ما وصلت 1500 (تمام) في يوم 4/10/2025 السابق 1500 والحالي 2800 ( تمام) القاطرة قبل تحركها كانت 1500 وبعد ما وصلت 2800 (تمام) لا حظ الأن أن الرقم 1500 كان الحالي في 1/10 وأصبح السابق في 4/10 والى الآن كل شيء معقول , ولكن ولكن ! =========== عند تطبيق نفس المنطق السابق على القاطرة 2 بترول يظهر خطأ في يوم 1/10/2025 السابق 250 والحالي 2500 القاطرة قبل تحركها كانت 250 وبعد ما وصلت 2500(تمام) في يوم 4/10/2025 السابق 2800 والحالي 5600( خطأ ) القاطرة قبل تحركها كانت 2800 وبعد ما وصلت 5600 (خطأ ) لا حظ الأن أن الرقم 2500 كان الحالي في 1/10 ولم يصبح السابق في 4/10 بل أصبح 2800 وهذا يدل على وجود فارق 300 (هنا المشكلة) تقبل تحياتي

زادك الله علما على علم وبارك الله فيك تعلمنا قبل الحل ......... الف شكر

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

عندي سؤال آخر عند استخدام عمود التاريخ للتحقق هل يقرأه كتنسيف dd/mm/yyyy أم كرقم؟ لأن المتغير عرفناه كرقم تاريخ وليس كتنسيق تاريخ

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

السلام عليكم جرب التعديل التالي Sub sav_PDFall() Dim i As Integer Dim folderPath As String Dim mainSheet As Worksheet Dim tempWorkbook As Workbook Dim firstRun As Boolean Set mainSheet = ThisWorkbook.ActiveSheet folderPath = ThisWorkbook.Path & "\ملاحظةالثانوية 2026" firstRun = True If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If Application.ScreenUpdating = False For i = 1 To mainSheet.Range("j3").Value mainSheet.Range("j2") = i If firstRun Then mainSheet.Copy Set tempWorkbook = ActiveWorkbook firstRun = False Else mainSheet.Copy After:=tempWorkbook.Sheets(tempWorkbook.Sheets.Count) End If Next i tempWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=folderPath & "\كشف_جامع_" & mainSheet.Cells(2, 4).Text & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True tempWorkbook.Close SaveChanges:=False Application.ScreenUpdating = True End Sub

جزاك الله خيراً أستاذنا الغالي .. ونسأل الله أن يرزقكم زيارة بيته معتمرين وحاجّين إن شاء الله

السلام عليكم ورحمة الله وبركاته هذه دعوة كريمة لتجربة الأداة الجديدة والفريدة من نوعها : دكتور ال VBA وضائف الأداة : 1- تحويل الكود إلى صيغة متوافقة مع النواتين 32 و 64 بت. 2- تصحيح الأخطاء البرمجية في الكود. 3- تنسيق وترتيب الكود شكليا. 4- كتابة التعليقات وشرح للكود باللغتين العربية والإنجليزية. 5- إضافة صائد الأخطاء للكود وذلك لتعقب الأخطاء البرمجية. 6- إضافة ترقيم لأسطر الكود. يمكنك اختيار واحد من هذه الوظائف أو تختار من بينها ما تريده. الأداة مخصصة لأكواد ال VBA وتعتمد على قدرات الذكاء الاصطناعي لإعطاء نتائج دقيقة ومبهرة .. 😁✌🏻 اختصر على نفسك الوقت والجهد واعمل بذكاء 😉👌🏻 رابط الأداة : https://vba-code-doctor-471932697586.us-west1.run.app/ يمكنك فتحها في الهاتف أو الحاسوب على راحتك 😎🌷 جربوها وعطوني رأيكم 😇✌🏻 :: إضافة جديدة :: لتحقيق مرونة أكبر للمستخدم ، أضفت حقل خاص بكتابة تعليمات مخصصة توجهها للذكاء الاصطناعي بحيث يراعيها عند معالجة الطلب ، مثال : ( قم بتغيير أسماء المتغيرات لأسماء مقروءة ، أو قم بتقسيم جملة SQL لعدة أسطر هكذا ....... ، أو ، أو ) أكتب ما شئت 🙂

طيب اعملها عن طريق mailing خاصية في الوورد ابحث عنها في اليوتيوب

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

خالص الشكر للمبدع الخبير الفاضل kkhalifa1960

استاذى ومعلمى الخبير الفاضل شكرا علي ابداعك منقطع النظير

جرب هذا الحل تسجيل الطرمبات2.xlsx

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

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

دي تحط تحتها 600 خط أحمر . هو مشروع جميل وفكرته حلوة بالنسبة لي ، ولكنه سيستغرق وقت وجهد طويل فعلاً ، لذا انصحك بانشاء الجداول بدايةً وباتباع اسلوب محدد وهو :- لا تستخدم أسماء عربية في مسميات الحقول . لا تستعمل المسافات بين الأسماء . لا تستعمل اسماء حقول محجوزة للبرنامج مثل ( Name,Date,To,From ..... إلخ ) لا تستعمل رموز ( #، @،$،& .... إلخ ) في مسميات الحقول . لا تستعمل الأرقام في أسماء حقول الجداول أو تبدأ بها . دي بعض الأساسيات بالنسبة لي اللي لازم أتبعها في تأسيس الجداول ، ثم اعتماد الحقل الرئيسي أو اللي لازم اربط فيه الأمور ببعضها ، وهنا هيكون رقم الكتاب المفتاح الفريد أو الغير مكرر . ابتدي وارفع ملفك ونتابع مع بعض لأنه طبعاً مستحيل يكون كل اللي انت وضحته في جلسة وحدة . بالتوفيق