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

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

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

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

السلام عليكم مشاركه مع اخى واستاذى محمد البرناوى اخى محمد حلك جميل ولكن بالنسبه للفقره الاول انت اختبرت المبلغ لو اقل ومع امثله الاستاذ الفاضل هو عاوز المبلغ اللى اكبر يتم طرحه يعنى مث ما هو موضح بالمثال بالاعلى 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 Dim آخرصف As Long Dim c As Long, r As Long Dim صف_الاخراج As Long Set ws = ActiveSheet صف_الاخراج = 1 ws.Columns(16).ClearContents For c = 1 To 13 آخرصف = ws.Cells(ws.Rows.Count, c).End(xlUp).Row For r = 1 To آخرصف If ws.Cells(r, c).Value <> "" Then ws.Cells(صف_الاخراج, 16).Value = ws.Cells(r, c).Value صف_الاخراج = صف_الاخراج + 1 End If Next r Next c End Sub

في اعلا النموذج لديك ضع دالة Sleep لانها غير موجودة لديك #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If

اليك الملف البحث في القائمة بالحروف.xlsm

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

العفو أخي الكريم .. يسعدنا أن تستفيد من المعلومة بشكل أكبر من الحلول الجاهزة التي ستتعرض لها مستقبلاً , جميع الجهود مشكورة لمن يحاول المساعدة . ولكن بنظري أن تصحيح المسار أفضل من السير في تعرج

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

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

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

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

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

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

وعليكم السلام ورحمة الله وبركاته كنت اتمنى دعم سؤالك بملف جرب التعديل التالي وان لم تعمل ارفق ملفا والمعادلة تعمل على اصدارات اكسل من 2013 وما فوق =IFNA(SUMPRODUCT((INDEX(A!$3:$1828;0;MATCH(H$8;A!$1:$1;0))<60)*ISNUMBER(INDEX(A!$3:$1828;0;MATCH(H$8;A!$1:$1;0)))*(A!$A$3:$A$1828=$C$6));"/")

شكراً لك للإفادة بالنتيجة .. والحمد لله على نجاح المهمة ..

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

طيب استخرج المجلد بجوار القاعدة ثم استخدم هذا الكود Sub ExportReports_To_OnePDF_PDFtk() Dim arrReports As Variant Dim i As Integer Dim strTempFolder As String Dim strFinalPDF As String Dim strPDFtk As String Dim strCmd As String strPDFtk = CurrentProject.Path & "\PdftkBuilderPortable\pdftk.exe" strTempFolder = CurrentProject.Path & "\TempPDF\" strFinalPDF = CurrentProject.Path & "\AllReports.pdf" arrReports = Array("rpt1", "rpt2", "rpt3") If Dir(strTempFolder, vbDirectory) = "" Then MkDir strTempFolder End If If Dir(strTempFolder & "*.pdf") <> "" Then Kill strTempFolder & "*.pdf" End If For i = LBound(arrReports) To UBound(arrReports) DoCmd.OutputTo acOutputReport, arrReports(i), acFormatPDF, _ strTempFolder & (i + 1) & "_" & arrReports(i) & ".pdf", False Next i strCmd = """" & strPDFtk & """ " & _ """" & strTempFolder & "*.pdf"" cat output " & _ """" & strFinalPDF & """" Shell strCmd, vbHide MsgBox "تم إنشاء ملف PDF واحد بنجاح ?" & vbCrLf & strFinalPDF, vbInformation Kill strTempFolder & "*.pdf" End Sub PdftkBuilderPortable.rar

السلام عليكم ورحمة الله تعالى اولا كل الشكر وكل التقدير والاحترام لكل رواد المنتدى المحترمين الافكار جميعها ولا اروع والان حان وقت مشاركتى فكرتى تعتمد على عمل التالى كلاس موديول عارف ان فى اجابات احتوت على افكار بسيطة جدا جدا جدا وفعالةوفكرتى هى كالاتى امكانية عمل نماذج تقييم متعددة ليحتوى احد النماذج على تقييم لا يتعدى الثلاث نجوم ونموذج اخر مثلا 5 نجوم وممكن نموذج كمان يحتوى على 10 نجوم فكرتى كود مركزى واحد يعمل على الجميع امكانية اعطاء نفس النجمة او ازالتها اما من نفس النجمة او بالنجمة التى تسبقها نبدأ شرح المنهج المتبع والفكرة والاكواد انشاء وحدة نمطية عامة من النوع كلاسس باسم: clsStarRating الكود سوف يكون: Option Compare Database Option Explicit ' ========================================== ' الثوابت الافتراضيةالخاصة ' ========================================== Private Const DEFAULT_SOLID_STAR As Long = &H2605 ' رمز النجمة المصمتة Private Const DEFAULT_HOLLOW_STAR As Long = &H2606 ' رمز النجمة المفرغة Private Const DEFAULT_TOTAL_STARS As Integer = 6 Private Const MAX_STARS As Integer = 20 ' ========================================== ' المتغيرات الخاصة Private mStarCount As Integer Private mRating As Integer Private mSolidSymbol As Long Private mHollowSymbol As Long Private mLastForm As Form Private mLastRatingField As String Private mStarsExpression As String ' ========================================== ' التهيئة ' ========================================== Public Sub Initialize(Optional ByVal starCount As Integer = DEFAULT_TOTAL_STARS, _ Optional ByVal SolidSymbol As Long = DEFAULT_SOLID_STAR, _ Optional ByVal HollowSymbol As Long = DEFAULT_HOLLOW_STAR) mStarCount = IIf(starCount >= 1 And starCount <= MAX_STARS, starCount, DEFAULT_TOTAL_STARS) mSolidSymbol = SolidSymbol mHollowSymbol = HollowSymbol mRating = 0 ClearCache End Sub ' ========================================== ' تبديل حالة التقييم ' ========================================== Public Sub StarClick(ByVal index As Integer) If index < 1 Or index > mStarCount Then Exit Sub mRating = IIf(index = mRating, IIf(index = 1, 0, index - 1), index) End Sub ' ========================================== ' تحميل/حفظ >-->> فائق الكفاءة ' ========================================== Public Sub LoadFromForm(Form As Form, ratingControl As String, Optional ByVal showMessage As Boolean = False) On Error GoTo ErrHandler mRating = Nz(Form.Controls(ratingControl).value, 0) CleanExit: Exit Sub ErrHandler: Debug.Print "LoadFromForm Error #" & Err.Number & ": " & Err.Description If showMessage Then MsgBox Err.Description, vbCritical Resume CleanExit End Sub Public Sub SaveToForm(Form As Form, ratingControl As String, Optional ByVal showMessage As Boolean = False) On Error GoTo ErrHandler If Form.NewRecord Then Exit Sub Form.Controls(ratingControl).value = mRating If Form.Dirty Then Form.Dirty = False CleanExit: Exit Sub ErrHandler: Debug.Print "SaveToForm Error #" & Err.Number & ": " & Err.Description If showMessage Then MsgBox Err.Description, vbCritical Resume CleanExit End Sub ' ========================================== ' محرك مركزى لتحديث عرض التقييم فى النموذج ' ========================================== Public Sub UpdateStarsForForm(FormObj As Form, ratingFieldName As String, _ Optional starPrefix As String = "txtStar", _ Optional textBoxName As String = "txtRatingText") On Error GoTo ErrHandler Static lastForm As Form, lastField As String If Not lastForm Is Nothing Then If lastForm Is FormObj And lastField = ratingFieldName Then Exit Sub End If Dim i As Integer, textExpr As String For i = 1 To mStarCount With FormObj.Controls(starPrefix & i) .ControlSource = "=Switch([" & ratingFieldName & "]>=" & i & _ ",ChrW(" & mSolidSymbol & "),True,ChrW(" & mHollowSymbol & "))" End With Next i ' نص التقييم (مرة واحدة) If Len(textBoxName) > 0 Then textExpr = "=Switch([" & ratingFieldName & "]=0,'بدون تقييم'," & _ "[" & ratingFieldName & "]=1,'نجمة'," & _ "[" & ratingFieldName & "]=2,'نجمتان'," & _ "True,[" & ratingFieldName & "] & ' نجوم')" FormObj.Controls(textBoxName).ControlSource = textExpr End If ' تحديث ذاكرة الكاش Set lastForm = FormObj lastField = ratingFieldName CleanExit: Exit Sub ErrHandler: Debug.Print "UpdateStars Error: " & Err.Description Resume CleanExit End Sub ' ========================================== ' تنظيف ذاكرة الكاش ' ========================================== Private Sub ClearCache() Set mLastForm = Nothing mLastRatingField = "" End Sub ---- اولا نبدأ بـــ :دليل التشغيل السريع لنظام تقييم النجوم أعداد اى نموذج مربعات النص المطلوبة: txtRatingValue ← مرتبط بحقل فى الجدول نوع الحقل رقمى ليسجل قيمة التقييم مثل ← (التقييم 0-10) txtRatingText ← (غير منضم ولا يرتبط بأى حقول فى الجدول) يعرض نص مثل ← "3 نجوم" مربعات نص txtStarX تبدأ من txtStar1 الى عدد النجوم التى تريد وضعها فى النموذج مثلا ← txtStar10 (غير منضمة جميعها ولا ترتبط بأى حقول فى الجدول) ← عرض نجوم التقييم ⭐ الأزرار btnStarX خصائصها شفافة وتكون بنفس عدد مربعات النص السابقة وتكون مواضعها فوق مربعات النص فى المقدمة كود النموذج Option Compare Database Option Explicit ' ========================================== ' إعدادات النموذج الثابتة (Configuration) ' ========================================== ' عدد النجوم Private Const cintTotalStars As Integer = 10 ' حقل التقييم Private Const cstrRatingControl As String = "txtRatingValue" ' بادئة أزرار النجوم Private Const cstrButtonPrefix As String = "btnStar" ' بادئة مربعات نص النجوم Private Const cstrStarPrefix As String = "txtStar" ' نص التقييم Private Const cstrTextControl As String = "txtRatingText" Private StarEngine As clsStarRating ' ========================================== ' فتح النموذج - التهيئة الكاملة ' ========================================== Private Sub Form_Open(Cancel As Integer) On Error GoTo ErrHandler Dim ctl As Control ' إنشاء محرك النجوم Set StarEngine = New clsStarRating StarEngine.Initialize cintTotalStars ' تحميل التقييم الحالي If Not Me.NewRecord Then StarEngine.LoadFromForm Me, cstrRatingControl End If ' ربط أزرار النجوم ديناميكيا For Each ctl In Me.Controls If ctl.ControlType = acCommandButton And ctl.Name Like cstrButtonPrefix & "*" Then ctl.OnClick = "=HandleStarClick(""" & ctl.Name & """)" End If Next ctl ' تحديث العرض StarEngine.UpdateStarsForForm Me, cstrRatingControl, cstrStarPrefix, cstrTextControl CleanExit: Exit Sub ErrHandler: Debug.Print "Form_Open Error #" & Err.Number & ": " & Err.Description MsgBox "خطأ في التهيئة: " & Err.Description, vbCritical, "Star Rating" Resume CleanExit End Sub ' ========================================== ' معالج ربط أحداث أزرار تقييم النجوم الديناميكي (مركزي) ' ========================================== Public Function HandleStarClick(ByVal strButtonName As String) As Variant On Error GoTo ErrHandler Dim intStarIndex As Integer intStarIndex = Val(Mid(strButtonName, Len(cstrButtonPrefix) + 1)) ' التحقق من صحة النجمة If intStarIndex < 1 Or intStarIndex > cintTotalStars Then HandleStarClick = False Exit Function End If ' تسلسل العمليات: Load >> Click >> Save >> Refresh StarEngine.LoadFromForm Me, cstrRatingControl StarEngine.StarClick intStarIndex StarEngine.SaveToForm Me, cstrRatingControl, False ' False = no message (بدون رسائل) HandleStarClick = True CleanExit: Exit Function ErrHandler: Debug.Print "HandleStarClick Error [" & strButtonName & "] #" & Err.Number & ": " & Err.Description HandleStarClick = False Resume CleanExit End Function ' ========================================== ' إغلاق آمن ' ========================================== Private Sub Form_Unload(Cancel As Integer) Set StarEngine = Nothing End Sub وطبعا يتم تعديل الاعدادت فى اعلى كود النموذج حسب المسميات ان اردت تغييرها فى النموذج بما يناسبك انت ' عدد النجوم Private Const cintTotalStars As Integer = 10 ' حقل التقييم Private Const cstrRatingControl As String = "txtRatingValue" ' بادئة أزرار النجوم Private Const cstrButtonPrefix As String = "btnStar" ' بادئة مربعات نص النجوم Private Const cstrStarPrefix As String = "txtStar" ' نص التقييم Private Const cstrTextControl As String = "txtRatingText" وبكده يكون معانا فكرة وتنفيذ لكود مرن لا يتطلب اى تدخل منك فى المستقبل ان اردت زيادة اعداد عناصر التقييم الا فقط باتباع نهج المواضع والمسميات لا تعديل فى الكود ولن تحتاج الى اضافة اى اكواد فى النموذج امكانية عمل اكثر من نموذج للتقييم فى نفس قاعدة البيانات على ان يكون لكل نموذج عدد تقييمات خاصة به وتختلف عن غيره وأخيرا اليكم مرفقا للتجربة والتقييم للفكرة وألية العمل الاستاذ الفاضل @ابوخليل اترك لكم حرية اختيار افضل اجابة لتكون مرجعا لرواد المنتدى ولكم خالص الشكر والتقدير لتقييم النجوم ( V1.2).accdb.zip

تفضل السمكة بالهناء والشفاء حساب مع الترتيب حسب المديونية رغم أني لا أفهم شيء في المحاسبة عملاء جديد.xlsb

اعتقد العمل ادناه ( نموذجي / مرن ) هذا ما امكنني الوصول اليه Private Sub SetRating(v As Integer) If Me.MyRating = v Then Me.MyRating = 0 Else Me.MyRating = v End If Me.Dirty = False End Sub Private Sub btnStar1_Click() SetRating 1 End Sub Private Sub btnStar2_Click() SetRating 2 End Sub Private Sub btnStar3_Click() SetRating 3 End Sub Private Sub btnStar4_Click() SetRating 4 End Sub Private Sub btnStar5_Click() SetRating 5 End Sub لتقييم النجوم2.rar

استخدم هذا <><><><><><><> Private Sub btnStar1_Click() If Me.MyRating = 1 Then Me.MyRating = 0 Else Me.MyRating = 1 End If Me.Dirty = False End Sub Private Sub btnStar2_Click() If Me.MyRating = 2 Then Me.MyRating = 1 Else Me.MyRating = 2 End If Me.Dirty = False End Sub Private Sub btnStar3_Click() If Me.MyRating = 3 Then Me.MyRating = 2 Else Me.MyRating = 3 End If Me.Dirty = False End Sub Private Sub btnStar4_Click() If Me.MyRating = 4 Then Me.MyRating = 3 Else Me.MyRating = 4 End If Me.Dirty = False End Sub Private Sub btnStar5_Click() If Me.MyRating = 5 Then Me.MyRating = 4 Else Me.MyRating = 5 End If Me.Dirty = False End Sub

وعليكم السلام ورحمة الله أنا معلم وتحولت إلى إداري على الحاسوب فكنت أعاني من هذا الأمر مهمتي هي العمل على الحاسوب وكل ما يلزم من أعمال المدرسة ومن ضمنها ادخال الدرجات للطلاب المعلم يسلمني الكشوفات وأنا بدوري أدخل الدرجات إلى النظام في البداية كنت متحمسا لهذا الشيء بسبب أن النظام كله هو من تصميمي ولكن ! مع مرور الوقت وجدت أن عملية الأدخال للدرجات فيها شيء من الصعوبة بسبب الأخطاء التي قد أرتكبها أنا من غير قصد مني ثم تظهر في نتيجة الطالب ويتم مراجعتي بعد ذلك لتعديلها فتداركت الموضوع حتى لا تتكرر الأخطاء في المرات القادمة وقمت بتطوير عملية الأدخال بعد المرحلةالاولى التقليدية كما يأتي : المرحلة الأولى : الطريقة التقليدية : كيبورد والضغط على الأزرار * في هذه المرحلة أي خطأ أنا أتحمله وبعدها فكرت التطوير وتقليل الاعتماد على الكيبورد وتقليل الضغط على الأزرار عندما أدخل الرقم 13 مثلا أحتاج للضغط على 3 أزرار : 1 و 3 و ENTER حتى يتنقل المؤشر للخلية التالية المرحلة الثانية : قمت بتصميم برنامج على الاكسل (لا أستخدم الكيبورد إطلاقا) يقوم بإظهار لوحة الدرجات على الشاشة وعن طريق الفارة (الماوس) أختار و أضغط على الدرجة المطلوبة فقط فيقوم البرنامج بادخال الدرجة للخلية وينزل المؤشر للأسفل تمهيدا لإدخال الدرجة الأخرى إذا 3 ضغطات في المرحلة الأولى = ضغطة واحدة من الماوس في المرحلة الثانية * وهذا أنجاز لكن في هذه المرحلة أيضا أنا أتحمل أي خطأ في الأدخال استمرت المرحلة الثانية عدة سنوات وطورت الفكرة إلى المرحلة الثالثة والنهائية وهي التي أعمل بها الآن المرحلة الثالثة : عملت كشوفات اكسل لكل صف ونزلتها في قروب واتساب الخاص بالمدرسة الذي يجمع كل المعلمين فكل معلم يحمل الكشف الخاص بصفه ومادته فقط ثم يعبي الدرجات ويرسل الكشوفات لي بالواتساب وأنا أقوم (عن طريق البرمجة وليس نسخ ولصق ) بإدراجها في النظام * وهنا أنهيت مسؤولتي وأصبح كل معلم هو المسؤول عن اخطائه إذا كان هناك طريقة أسهل من هذه فأرجو من الأخوة القراء أتحافنا بها فالجميع يريد الوصول لهدف واحد وهو تبسيط العمل تقبل تحياتي .

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

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

وعليكم السلام ورحمة الله وبركاته حسب طلبك في الرسائل الحاصة استاذ هذا هو طلبي لقد اعادة ملف الاكسيل لقد حاولت وضع الكود ولم اسطيع الاجابة على طلبك ارجع الى اول ملف في مشاركتك الاولى اسم الملف (امتداده) يتنهي xlsx ارجع الى الملف الذي ارفقت لك به الاجابه وبه الكود اسم الملف (امتداده) يتنهي xlsb لماذا قمت انا بتغيير امتداد الملف من xlsx الى xlsb ؟ لسبب بسيط وهو ان اي ملف اكسل يتنهي اسمه (امتداده) xlsx لا يمكن ان يحفظ كود في هذه النوعية من الملفات ماذا يحدث لو وضعت كوداً في ملف xlsx؟ إذا قمت بوضع كود داخل ملف xlsx ثم قمت بالحفظ: ستظهر لك رسالة تنبيه واضحة. إذا ضغطت "نعم" (Yes) للحفظ بصيغة xlsx فسيقوم إكسل بمسح الكود تماماً. عند فتح الملف مرة أخرى، لن تجد أي أثر للكود الذي كتبته. وملفك الاخير بنفس الامتداد xlsx فلن يتم حفظ الكود لذلك عند حفظ الملف وظهور رسالة التنبيه احتيار لا بدل نعم كما في الصور المرفقة اليك الملف وبه الكود بغد تحويله من xlsx الى xlsb وهو نفس الملف في احر مشاركة لي Employees.xlsb

جرب التعديل التالي test2.xlsm

السلام عليكم جرب التعديل التالي 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، عندما نستخدم SumIfs مع التواريخ، يفضل تمرير التاريخ كقيمة رقمية (Long) اذا كانت الكميات ارقام صثحيحة و Double بدلاً من Long تحسباً لوجود كسور في الكميات (إذا كانت الكمية تحتوي على فواصل عشرية ) ، لأن تحويله إلى نص (String) مثل "MM/dd/yyyy" قد يتسبب في عدم تطابق البيانات إذا كان إعداد التاريخ في الجهاز مختلفاً. جرب التعديل بالملف المرفق SUMIFS_VBA.xlsm

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

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

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

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

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

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

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

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

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

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

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