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

السلام عليكم سوف نشرح في هذا الموضوع طريقة سهلة جدا لإضافة QR CODE للتقرير داخل مربع نص و يدعم اللغة العربية كذلك أولا: هناك ملف تنفيذي يقوم بتسجيل الأدوات و نوع الخط نقوم بتثبيته داخل الكمبيوتر ثانيا: لإضافة QR CODE نقوم باستدعاء الوحدة النمطية الموجودة في المرفق في مصدر عنصر التحكم لمربع النص و نغير نوع الخط إلى BCW_2D =QrCode([T];1;1;صواب;4;1) [T]: هو مربع نص نأخذ منه البيانات و هذا رابط المصدر : https://barcodewiz.com/user-manual/qr-code-fonts/create_qr_code_barcodes_in_ms_access.aspx و أخيرا تمتع بـQR CODE رائع أرجوا من الإخوة تجربته و موافاتنا بالنتائج. توليد QR CODE.rar

وهل تتخيل وتتوقع انه يمكن العمل على التخمين ؟!!! فكيف تتم المساعدة بدون ملف مدعوم بشرح كافى ووافى عن المطلوب , مع وضع النتائج المرجوة فهذه المشاركة ما هي الا انها أدت لإهدار وقت الأساتذة بلا فائدة

بعد إذن الأستاذ مهند أولاً قم بالذهاب إلى المطور ثم اختر إدارج يظهر صندوق اختر منه مربع تحرير وسرد بعد ذلك قم بالضغط والسحب ليتم رسم الشكل قم بعمل كليك يمن على الشكل يظهر شكل اختر تنسيق عنصر تحكم اختر منه عنصر تحكم قم بإدخال النطاق ثم حدد ارتباط الخلية مرفق صورة للتوضيح 33.xls

ممكن نجربة هذا الكود اذا لم يكن هناك صفحة بأي اسم يقوم الماكرو باضافة صفحة جديدة بهذا الاسم و ينقل البيانات اليها Option Explicit Sub Add_sheet() Dim myname As Worksheet Dim P As Worksheet Dim sh_n%, k%, i% Set P = Sheets("اليوميه") sh_n = Application.CountA(P.Range("B:B")) - 1 Dim x%, t%: t = 2 Dim mn$ Application.ScreenUpdating = False ''''''''''''''''''''''''''''''''''''''''' For i = 2 To sh_n On Error Resume Next mn = Sheets(P.Range("b" & i) & "").Name x = Len(mn) If x = 0 Then P.Copy after:=Sheets(Sheets.Count) With ActiveSheet .Name = P.Range("b" & i) .Range("G14") = P.Range("F" & i) .Range("a1").CurrentRegion.Offset(1).ClearContents .Range("A:A").NumberFormat = ("dd- mm-yyy") For k = 2 To sh_n + 1 If P.Range("b" & k) = ActiveSheet.Name Then ActiveSheet.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next End With '========================================= Else Set myname = Sheets(P.Range("b" & i) & "") myname.Range("a1").CurrentRegion.Offset(1).ClearContents For k = 2 To sh_n + 1 If P.Range("b" & k) = myname.Name Then myname.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next '''''''''''''''''''''''''''''''''''' End If mn = "" Err.Number = 0 t = 2 Next i P.Select Application.ScreenUpdating = True End Sub الملف مرفق tarhil_by_names.xlsm

العفو أخي

ممكن تبدليه بهذا الكود Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select ElseIf Target.MergeCells = True And Target.HasFormula = True Then Target.Offset(0, 1).Select ElseIf ActiveCell.HasFormula = True And ActiveCell.MergeCells = True Then ActiveCell.Offset(0, 1).Select End If End Sub و بعذ إذن أستاذنا الفاضل سليم أرى أن يكون التعديل هكذا اكتب في السطر الذي قبل كلمة Dim في الماكرو ActiveSheet.Unprotect "123" واكتب في السطر الذي قبل كلمة End sub ActiveSheet.Protect "123" Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False ActiveSheet.Unprotect "123" Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True .InsertIndent 1 End With Exit_Sub: Application.ScreenUpdating = True ActiveSheet.Protect "123" End Sub My_students (1).xlsm

جزاكم الله كل خير

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

وعليكم السلام-تفضل لا يمكن الا بهذه الطريقة لا تترك رقم الوحدة فى اى صف فارغ تحصيل2.xlsm

وعليكم السلام ورحمة الله وبركاته ارفق مثال اخي الكريم لفهم المطلوب ولك الشكر تحياتي

تفضل اخي الكريم لاحظ مصدر combobox في النموذج والمعيار الموجود في الاستعلام Query1 w.rar تحياتي

تفضل أخي error.rar

انظر المرفق ..... لسرعة الاجابة حاولت تعديل حقول الجدول لديك .... Database1.mdb

بالتوفيق ....

جرب الكتابة داخل المربع الأول وانظر النتيجة .... ايقاف علامة جدولة.accdb

تفضل ....... Data.rar

اسف جدا كثرة الملفات علي .... انظر المرفق الجديد ..... تم تعديل المرفق .....اسف مرة أخرى QR_code_-name.mdb

نعم ممكن ولكن في حالة كثرة السجلات مثل مثالك يحتاج وقت وايضا كفاءة جهاز الكمبيوتر ..... انظر المرفق هذا ما تريد تم تعديل المرفق .... Desktop1.rar

الشكر لله ثم لاخواننا واساتذتنا الذين تعلمنا ونتعلم منهم جزاهم الله خيرا وفيك بارك الله اخى تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق

وعليكم السلام اخى خلف انظر التعديل ده هل هو ما تريد اذا كان هو فجزاه الله خيرا اخى @Ali Sadiq فقد استفدت منه هذا الكود الجميل تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق تصفية_نموذج_مسافة.rar

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

تفضل أخي اليك التطبيق المثال تجربة قبول التكرار مع رسالة تحدير.rar

قبل اول كلمة Dim في الماكرو اكتب هذا السطر و بذلك يقوم الماكرو بعمله حتى ولو كانت الورقة محمية ActiveSheet.Protect "123", UserInterfaceOnly:=1 ليصبح الماكرو بهذا الشكل Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False '++++++++++++++++++++++++++++++++++++++++++++++++++++++ ActiveSheet.Protect "123", UserInterfaceOnly:=1 '++++++++++++++++++++++++++++++++++++++++++++++++++++ Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True End With Exit_Sub: Application.ScreenUpdating = True End Sub الملف مرفق My_students_Protected.xlsm

أ / مصطفى كمال متولى لا شكر على واجب المهم أنه تم تنفيذ المطلوب بنجاح

المشكلة لديك انت كما توقعت فيجب عليك تفعيل والتعليم على هذا الخيار ايضا وهو Trust Access

محاولة منى جرب الكود =IF(B1="نصف";A1&"و "& B1;SUM(A1:B1)) إذا لم تشتغل المعادلة استبدل الفاصلة المنقوطة بفاصلة مرفق ملف جمع.xlsm

انظر اخي الكريم للملف نفس الموضوع بدون وحدات نمطيه اتمنى ان يعمل عندك تحياتي images.rar

السلام عليكم انظر للملف اخي الكريم اتمنى ان يكون المطلوب تحياتي استعلام الحاق بالكود.rar

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

اللهم امين ولك مثله

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

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

السلام عليكم ورحمة الله استخدم الكود التالى بعد وضعه فى حدث ThisWorkBook دبل كليك على الخلية A1 فى كل مرة Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) If Target.Address <> "$A$1" Then Exit Sub On Error GoTo 1: For i = 1 To Sheets.Count If ActiveSheet.CodeName = Sheets(i).CodeName Then Sheets(i + 1).Activate Exit For End If Next 1: Exit Sub End Sub

اخي مهند لا شيء مستحيل مع برنامج اكسل هذه المعادلة في C5 واسحب نزولاً (يمكن تغير الرقم 7 الى ما تريد والنقطة الى ما تريد ايضاً مثلا * داخل الدالة REPT) =REPT(".",7)&VLOOKUP($I$1,ورقة1!$B$6:$E$27,ROWS($C$5:C5)+1,0)&REPT(".",7) الملف مرفق New_Book.xlsx

ادخل دالة Nz في تلك العمليات

وعليكم السلام ورحمة الله وبركاته في حدث عند الخروج حدد الحقل الذي يريد الانتقال اليه Private Sub aa_Exit(Cancel As Integer) DoCmd.GoToControl "d" End Sub او الانتقال الى سجل جديد Private Sub aa_Exit(Cancel As Integer) DoCmd.GoToRecord , , acNewRec End Sub تحياتي

كفكرة هل جربت nz

السلام عليكم جرب المعادلة التالية: * بالفرنسية : =ARRONDI.AU.MULTIPLE(8465.46;10) * بالإنجليزية : =MROUND(8465.46;10) ملاحظة : يجب أن تراعى الفاصلة المنقوطة والفاصلة في هذه المعادلات حسب النظام المعمول به...

حياك الله أخي @haniameen وبالتوفيق ...

جرب هذا الماكرو Option Explicit Sub ABSCENT() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 2) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "Q") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub الملف مرفق Tarhil_3iyab.xlsm

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

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

السلام عليكم مرفق ملف يشرح داله subtotal subtotal.rar

لا أعلم اذا كان هذا المطلوب Leave_book.xlsx

اولا احب ان اشكر كل اعضاء و مشرفى هذا المنتدى العظيم الذى تعلمت و لازلت اتعلم منه الكثير و الكثير و اليوم اقدم الى الجميع برنامج المخزون الشامل حيث قد طلب منى احد الاصدقاء برنامج لضبط حركه مخزون شركته وهى شركه مستحضرات تجميل فقد قمت بعمل هذا البرنامج الذى يصلح لكل انواع المخزون مع بعض التعديلات البسيطه نبذه صغيره عن البرنامج 1-برنامج يحتوى على صفحه فواتير المبيعات و المشتريات و المرتجعات 2-و يحتوى على صفحه كشف حسب العملاء التى توضح المدفوع و المستحق خلال فترات معينه 3- صفحه التقارير وتضم حركه الاصناف حركه الفواتير وتقرير شامل بالمبيعات و المشتريات خلال اى فتره انت تحددها 4- كما يمكنك ادخال اى سند سواء كان صرف او قبض من خلال فورم ادخال السندات 5- حركه المخزون و التى توضح الربح و الخساره لكل صنف على حده و المزيد و المزيد من المزايا الاخرى التى سوف تكتشفها بنفسك ملاحظات تم عمل البرنامج على اكسيل2010 وتم تجربته بنجاح على اكسيل 2010 الرقم السرى للدخول الى البرنامج هو 123 وانصح جميع الاخوه الذين يجربون البرنامج ان يتم تجريبه على نفس الاصدار تجنبا لحدوث اى مشاكل تم رفع البرنامج على موقع الميديا فير حيث ان حجم البرنامج 2 ميجا بايت كما ارحب براى الاخوه و الخبراء فى البرنامج سواء كان نصيحه او نقد او معلومه جديده كما انوه باننى جاهز لاى استفسار او تعديل لهذا البرنامج لمن يريد على حسب طبيعه عمله و على حسب وفت فراغى و اخيرا اشكر كل اعضاء ومشرفى هذا الصرح العظيم الذى تعلمت منه التحميل من الرابط التالى http://www.mediafire.com/file/u34hp2c38h6slc7/برنامج المخزون الشامل.rar برنامج المخزون الشامل.rar

شاهد المرفق الكود Function RESULTA(rng As Range) As String Application.Volatile Dim c As Integer Dim r As Integer Dim str As String Dim subj As String c = rng.Column r = rng.Row subj = Cells(2, c - 3).Text str = "راسب في مادة " & subj & " " If Cells(r, c) = "غ" Then str = str & "بسبب غيابه في العملي و" If Cells(r, c + 1) = "غ" Then str = str & "بسبب غيابه في التحريري و" If Cells(r, c) < Cells(9, c) Then str = str & "لعدم حصوله علي ربع الدرجة في العملي و" If Cells(r, c + 1) < Cells(9, c + 1) Then str = str & "لعدم حصوله علي ربع الدرجة في التحريري و" If Cells(r, c + 2) < Cells(9, c + 2) Then str = str & "لعدم حصوله علي ربع الدرجة في الكلية و" str = Left(str, Len(str) - 2) If Len(str) < 20 Then str = "ناجح" RESULTA = str End Function المصنف1.xlsm

اليك الحل Employee Data - 2015salim.rar

تفضل أستاذ حمدي .. يا بختك بموضوعك هذا حل آخر بالكود مشابه لحل الأستاذ الكبير أبو تراب (مع إمكانية أن يكون المدى مطاطي أي غير ثابت Dynamic) Distinct Validation List Across Columns.rar

السلام عليكم إخوتي الاحبه أعضاء وأساتذة منتدانا الغالي أقدم كود يقوم بالبحث في سلسلة نصيه ويستخرج ( الكلمات العربيه - والكلمات الانجليزي - والأرقام ) وكل سلسلة في عمود المدى الإفتراضي عمود "A" أرجو التجربه إن وجدت اي ملاحظات أو أخطاء Public Sub Cnvrt_Ali() Dim L_A&, i& On Error Resume Next ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\System32\vbscript.dll\3" On Error GoTo 0 With ActiveSheet L_A = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 2 To L_A .Range("B" & i).Resize(1, 3).Value = S_Nm_Ali(.Range("A" & i).Value) Next i End With End Sub Private Function S_Nm_Ali(ByVal Nms As String) Dim E$, A$, Nm$ Dim V_r As Object Set V_r = CreateObject("VBScript.Regexp") On Error Resume Next With V_r .Global = True .IgnoreCase = True .Pattern = "\w|\n|\-|\(|\)|\&|\." A = Trim(.Replace(Nms, "")) .Pattern = "\D+" E = Trim(.Replace(Nms, "")) .Pattern = "[-?\d+(\.\d+)?|\u0600-\u06FF]" Nm = Trim(.Replace(Nms, "")) End With S_Nm_Ali = Array(A, E, Nm) Set V_r = Nothing End Function Ali_String.rar

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