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

يمكنكم الاطلاع على هذا المرفق https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=129345

وعليكم السلام ورحمه الله وبركاته تفضل اخي 2024.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب اظنه اسرع Sub TEST1() Dim WS As Worksheet, sh As Worksheet Set WS = Sheets("Feuil5"): Set sh = Sheets("Feuil6") LR = WS.Cells(Rows.Count, 3).End(xlUp).Row Application.ScreenUpdating = False sh.Range("A10:M" & sh.Rows.Count).ClearContents a = WS.Range("A10:K" & LR).Value Dim tmp(): ReDim tmp(1 To UBound(a)) For I = LBound(a) To UBound(a) On Error Resume Next If a(I, 2) = sh.[E3] And a(I, 11) = sh.[F3] Then n = n + 1: tmp(n) = I ' بما ان رموز الفواتير ثابثة بين 0 . و 1 اجعل الشرط بهده الطريقة ' If a(I, 2) = sh.[E3] And a(I, 11) >0 Then n = n + 1: tmp(n) = I Next ReDim Preserve tmp(1 To n) a = Application.Index(a, Application.Transpose(tmp), _ Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")"))) sh.[A10].Resize(UBound(a), UBound(a, 2)) = a Application.ErrorCheckingOptions.BackgroundChecking = False Application.ScreenUpdating = True End sub حساب العملاء 2024.xlsm

تفضل اخي تم استبدال الكود ليتناسب مع متطلباتك الحالية مع دمج الاكواد السابقة في نفس الملف Sub CopyData2() Dim x&, OneRng As Range, rCrit As String Dim srcWS As Worksheet, WS As Worksheet Dim i As Long, lrow As Long Set srcWS = Sheets("Data") Set WS = Sheets("FORM3"): rCrit = WS.[G2].Value 'قم بتعديل كود التفقيط بما يناسبك Const iCnt As String = "=IFERROR(@NombreToArabe(E9),"""")" If IsEmpty(WS.[G2].Value) Then: Exit Sub Set OneRng = srcWS.Columns(3).Find(What:=rCrit, LookIn:=xlValues, LookAt:=xlWhole) If OneRng Is Nothing Then MsgBox rCrit & " : " & "غير موجودة", vbInformation: Exit Sub Else Application.ScreenUpdating = False lrow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row For i = 11 To lrow Union(WS.Range("C" & i), WS.Range("E" & i)).ClearContents Next i x = OneRng.Row WS.[A9] = srcWS.Cells(x, 1) 'الرقم WS.[B9] = srcWS.Cells(x, 2) 'رقم صفحة WS.[C9] = srcWS.Cells(x, 3) 'نوع اللوازم و مواصفاتها WS.[D9] = srcWS.Cells(x, 4) 'رصيد السجل WS.[E9] = srcWS.Cells(x, 33) 'المجموع With WS.[F9] 'العدد كتابة .Formula = [iCnt]: .Value = .Value End With tmp = srcWS.Range("A4:AF" & srcWS.Cells(Rows.Count, 3).End(xlUp).Row).Value2 Dim a(): ReDim a(1 To UBound(tmp) * UBound(tmp, 2), 1 To 5) n = 0 For ligne = 1 To UBound(tmp, 1) For Col = 6 To UBound(tmp, 2) If tmp(ligne, 3) = rCrit And tmp(ligne, Col) <> "" Then n = n + 1 a(n, 2) = tmp(1, Col) 'رؤوس الاعمدة a(n, 4) = tmp(ligne, Col) ' رصيد الغرف المتوفرة End If Next Col Next ligne WS.Cells(k + 11, 2).Resize(n, 3 + 1) = a IRow = WS.Cells(Rows.Count, "E").End(xlUp).Row + 1 WS.[F11] = Application.Sum(WS.Range("E11:E" & IRow)) ' مجموع عمود الرصيد End If Application.ScreenUpdating = True End Sub لقد لاحظت انك لديك القدرة لفهم الاكواد من خلال التعديلات التي قمت بها على الاقتراحات السابقة . حاولت توضيح بعض النقط المهمة على الكود ليسهل عليك التعديل على حسب احتياجاتك مستقبلا. بالتوفيق ..... DATA V4.xlsb

تفضل أخي محمود 🙂 قائمة منسدلة تسهل لك تحديد التواريخ لنموذج البحث.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) طبعاً المكتوب باين من عنوانه . هي اللعبة المعروفة والتي لعبها منا على الأغلب الجميع في طفولته .. من يبدأ اللعب هو من يحصل على أعلى رقم من القرعة . اللعبة يلعبها لاعبين اثنين فقط . يتم تسجيل النقاط لكل لاعب في خانة منفصلة . طريقة التحرك بنمط حجر النرد ( ولا أعلم إن كان البعض سيقول لي أن النرد حرام ) لكنه هنا ليس حجر نرد حقيقي وإنما فكرة اختيار عشوائي لصور أوجه حجر النرد ) الأرقام ) تدل على خطوات التقدم . الصعود لأعلى عند وصول اللاعب إلى أول السلم حتى الخانة التي تمثل رأس السلم . وكما الصعود !! سيكون لدينا النزول عند وصول اللاعب إلى رأس الثعبان سينزل باتجاه الذيل نزولاً .. تسجيل الحركات الإنتقالية لكل لاعب في مربع الحركات أسفل اللعبة . في حال الوصول إلى 95 سيحتاج اللاعب للوصول إلى الهدف 100 إلى 6 نقاط أو أقل ، فلو تقدم الى 99 كمثال هنا سيحتاج الى نقطة واحدة للتحرك وللفوز . فلو كان الاختيار العشوائي للصورة فرضاً 4 فلا يتم تحقيق الفوز إلا بالرقم 1 .... وهكذا . عند فوز أحد اللاعبين ، سيتحول الزر إلى لعبة جديدة . إمكانية تكبير النموذج لملئ الشاشة أو لا ، حسب رغبتك صور من اللعبة :- ملف اللعبة مفتوح المصدر Snake3.accdb

بارك الله فيك ا/ حسونة حسين جعل الله فى ميزان حسناتك

تفضل اخي Dim Stock_check As Boolean, Product_check As Boolean Stock_check = Application.WorksheetFunction.CountIf(fa.Range("E2:E" & Uf), ComboBox1) > 1 Product_check = Application.WorksheetFunction.CountIf(fa.Range("A4:A" & Uf), .Cells(J, 1)) > 1 If (fa.Cells(J, 4).Value) = 0 And Stock_check = True And Product_check = True Then fa.Cells(J, 4).EntireRow.Delete End If

شكراً لمروروك صديقي @TQTHAMI ، كلامك سليم ، ولكن اللعبة هنا تحتوي على 10 صور فقط وهي ( 6 صور لأوجه حجر النرد + 4 صور بين القرعة واللاعب الأول والثاني واللعبة الجديدة )

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

شكرا جزيلا أخي الفاضل وبارك الله فيك وأكثر الله من أمثالك وجعله في ميزان حسناتك معلش أنا بتعبك معاي كثيرا أخوك لسه بيتعلم وبحاول اصمم برنامج كنترول

هنا المشكلة يا صديقي ، تكمن في اختلاف الدقة من كمبيوتر إلى آخر ,, على العموم مشكور على المحاولة اللطيفة ,, بعد تجربته على ملف خاص كانت نسبة النجاح في تحقيق الهدف 85% مقارنة مع الكود الذي أشرت إليه سابقاً ..

طار الموضوع من فكري ههههههههه خربطت لقد قمت بتجربة (لا اعرف صح ولا طبقتها بشكل خاطئ) اتمنى ان تشاركوني بها يا حبايبي لقد قمت بتكوين موديول Resize وهو Option Compare Database Declare PtrSafe Function DisplaySize Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long Function resizefrom(frm As Form, bestw As Integer, besth As Integer) On Error Resume Next wrate = DisplaySize(0) / bestw hrate = DisplaySize(1) / besth frm.InsideWidth = frm.InsideWidth * wrate frm.InsideHeight = frm.InsideHeight * hrate Dim fc As Control For Each fc In frm.Controls fc.Top = fc.Top * hrate fc.Left = fc.Left * wrate fc.Width = fc.Width * wrate fc.Height = fc.Height * hrate fc.FontSize = fc.FontSize * wrate Next End Function و استدعيتها من الفورم عند التحميل هكذا resizefrom Me, DisplaySize(0), DisplaySize(1) DoCmd.Maximize الامر الى الان طبيعي عند دقة الشاشة 1336*768. عندما اغير دقة الشاشة الى 800*600 هنا تبدا المعركة (على فرض انني اعطيت البرنامج الى شخص اخر شاشته 600*800) يتغير محتويات الفورم كما في الصورة ادناه. اليس من المفروض يتوسط و يتحجم كل المحتويات في الفورم حسب الدقة الجديدة 600*800 ؟؟ ام انا مخطئ ,تحياتي لكم

تمام جدا جدا ربنا يكرم حضرتك يا رب العالمين ويحفظك بحفظ القرأن

السلام عليكم دي مساهمة مني في المطلوب وباذن الله تجد فيها ضالتك انا جربتة علي الشبكة شغالة تمام دخول رئيس المصلحة بباص وورد 111 ومدير مكتبة 222 كل شخص بنموذج مختلف تحياتي mm.rar

احسنتم هو المطلوب

الأستاذ الفاضل هذا هو المطلوب بالتفصيل بارك الله فيك وجعله في ميزان حساناتك ان شاء الله

**كود حذف الأصفار من شمال الأرقام في ملفات Word:** ``` Sub RemoveLeadingZeros() Dim rng As Range Dim findWhat As String findWhat = "<0" Set rng = ActiveDocument.Range With rng.Find .ClearFormatting .Text = findWhat .Replacement.ClearFormatting .Replacement.Text = "" .MatchCase = False .MatchWholeWord = False .MatchWildcards = True .Execute Replace:=wdReplaceAll End With End Sub ``` **كيفية استخدام الكود:** 1. افتح ملف Word الذي يحتوي على الأرقام التي تريد تعديلها. 2. اضغط على "Alt + F11" لفتح محرر Visual Basic. 3. انقر فوق "إدراج" > "وحدة نمطية". 4. الصق الكود في وحدة النمط. 5. اضغط على "F5" لتشغيل الكود. سيقوم هذا الكود بحذف جميع الأصفار الموجودة على يسار الأرقام في الملف. **ملاحظة:** * هذا الكود يحذف فقط الأصفار الموجودة على يسار الأرقام. * إذا كنت تريد حذف أصفار إضافية من داخل الأرقام، يمكنك تعديل الكود وفقًا لذلك.

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

الأستاذ الفاضل @Foksh ممتاز جدا جدا شغال بامتياز استمسحك سأجربه على بيانات كبيرة و اوافيك بالنتيجة

اجعل قيمة الحقل الافتراضية "الرقم" في الجدول = 0

انا عن نفسي قمت باستخدام مشاركة الأخت @safaa salem5 في هذه المشاركة والأمر ناجح معي بنسبة 99%

تفضل اخي @qathi ، هل هذا طلبك ؟؟ ScanPro.zip

اعتذر منك أخي الكريم @2saad ، فعلاً العنوان لا يدل على سؤالك وطلبك في المشاركة الثانية على العموم . هل هذا طلبك mas.zip

نحتاج هذا الموضوع

عندي هذا النموذج الرائع منذ سنوات واستخدمه في كل برامجي هو للامانة ليس من تصميمي اتوقع صممه الأخ الحبيب @ابو جودي اقدمه لكم هديه فهناك من يحتاجه بحث حسب تاريخ.accdb

عليكم السلام طلبك غير دقيق .. اقصد ان البحث غير دقيق .. لانه يمكن وجود الصنف نفسه في اكثر من مكان ومع اكثر من نوع ( فأي منها تريد تكراره ) فاهمني ؟ تم التعديل حسب المطلوب التوريد2.rar

السلام عليكم ورحمة الله وبركاته ، أتشرف بتلبية دعوتكم للمشاركة أخي @سلمان الشهراني . واسمحوا لي بالبدء بأول تفاعل بعد معلمي الفاضل @ابوخليل ، وبانتظار أساتذتي للدعم وتصحيح مفاهيمي إن كانت خاطئة . بداية أعتقد وجوب وجود المكتبة Microsoft Script Runtime ، هذا الكود الذي خلصت به ولا أعلم إن كانت النتيجة صحيحة كما تريدون أم لا ، إلا أنني قمت بالتجربة على الموقعين في الفيديو وكانت النتيجة مرضية ومطابقة ( الموقع الأول ، الموقع الثاني ) . فيما يلي ، الكود الأول لتحويل النص إلى SHA256 Hex Function TextToBase64(ByVal text As String) As String Dim sha As Object Dim utf8Bytes() As Byte Dim hash() As Byte Dim i As Integer Dim hashHex As String Set sha = CreateObject("System.Security.Cryptography.SHA256Managed") utf8Bytes = StrConv(text, vbFromUnicode) hash = sha.ComputeHash_2(utf8Bytes) hashHex = "" For i = LBound(hash) To UBound(hash) hashHex = hashHex & Right("0" & Hex(hash(i)), 2) Next i TextToBase64 = Base64Encode(hashHex) Set sha = Nothing End Function Function Base64Encode(ByVal strData As String) As String Dim objXML As Object Set objXML = CreateObject("MSXML2.DOMDocument").createElement("b64") objXML.DataType = "bin.base64" objXML.nodeTypedValue = strData Base64Encode = objXML.text Set objXML = Nothing End Function والنتيجة يتكون في مربع النص ( الهدف الأول ) عن طريق زر الإستدعاء كما يلي :- Private Sub btnComputeHash_Click() If IsNull(Me.txtInput) Then MsgBox "يرجى إدخال قيمة ليتم تشفيرها", , "" Me.txtInput.SetFocus Exit Sub End If Dim myText As String myText = Me.txtInput Dim base64Hash As String base64Hash = TextToBase64(myText) Me.txtHashOutput = base64Hash End Sub ثم باستخدام هذا الكود وبعد عدة تجارب يتم تحويل الـ Hex إلى Base64 : Function HexToBase64(ByVal hexString As String) As String Dim bytes() As Byte Dim objXML As Object bytes = HexStringToBytes(hexString) Set objXML = CreateObject("MSXML2.DOMDocument").createElement("b64") objXML.DataType = "bin.base64" objXML.nodeTypedValue = bytes HexToBase64 = objXML.text Set objXML = Nothing End Function Function HexStringToBytes(ByVal hexString As String) As Byte() Dim bytes() As Byte Dim i As Integer ReDim bytes(Len(hexString) \ 2 - 1) For i = 1 To Len(hexString) Step 2 bytes((i + 1) \ 2 - 1) = Val("&H" & Mid(hexString, i, 2)) Next i HexStringToBytes = bytes End Function ويتم الاستدعاء في الزر كالآتي :- Private Sub Btn_Base64_Click() If IsNull(Me.txtHashOutput) Then MsgBox "لم يتم حساب قيمة Hex بعد.", , "" Exit Sub End If Dim base64Value As String base64Value = HexToBase64(Me.txtHashOutput) Me.Txt_Base64 = base64Value End Sub وفي النهاية أترك التجربة للحكم والتعديل . Hash Con.accdb

أهلا بك أخي @سيد رجب 🙂 فكرة البرنامج جميلة جدا وإبداعية .. لكن في التصميم الصحيح لقاعدة البيانات أنت في غنى عن الخطوات المعقدة التي ذكرتها 🙂 ستحتاج لجدول واحد فقط لحفظ بيانات الطلبات سواء الموافق عليها أو المكتملة أو التي في الانتظار .. فقط ستحتاج لإضافة حقل به قائمة منسدلة توضح حالة الطلب (انتظار - موافق عليه - مكتمل - مقبول - مرفوض) مثلا .. وبعد ذلك تعمل 5 استعلامات مثلا .. كل استعلام يعرض حالة واحدة للطلبات ( مثال : استعلام يعرض جميع الطلبات المكتملة فقط .. ) .. وهكذا لبقية الحالات .. ثم تجعل هذه الاستعلامات مصدر للنموذج الذي سيعرض الطلبات حسب الحالة المطلوبة ( مثال : نموذج لعرض الطلبات التي قيد الانتظار ) ( ونموذج لعرض الطلبات الموافق عليها ) وآخر للمكتملة وآخر للمرفوضة وهكذا .. ولنقل الطلبات من حالة إلى أخرى كل ما عليك فعله هو تقيير القيمة المكتوبة في حقل الحالة (يمكن عملها أوتوماتيكيا بالكود ) ... وستقوم الاستعلامات تلقائيا بنقل الطلب للتصنيف المناسب . ملاحظة : لن تحتاج لعمل ملفي أكسس ( واحد للمرسل والآخر للمستقبل ) .. ضع جميع النماذج والاستعلامات والتقارير في ملف واحد فقط ووزعه للمرسلين والمستقبلين (نفس الملف) .. اللهم عن طريق صلاحيات المستخدمين اجعل لكل مستخدم مساره الخاص حسب نوع المستخدم ( مرسل أو مستقبل ) ، لكل شخص تظهر له النماذج الخاصة به فقط .. بعد قراءة هذه الأسطر إبدأ في التطبيق والمعين الله 🌼🙂 .. وانتقل بعدها للخطوة التالية ..

تفضل أخي هذا حل سريع كما بالصورة .

اتفضل استاذ محمد الملف لعله يفى بالغرض xD.xlsm