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

السلام عليكم ورحمة الله يمكنك استخدام الكود التالى Sub JnQuran() Dim ws As Worksheet, LR As Long Dim Arr(), Tmp, Tgrt As String, Reslt As String Dim i As Long, j As Long, p As Long Set ws = Sheets("حفص") LR = ws.Range("E" & Rows.Count).End(3).Row Tgrt = ws.Range("L17") Arr = ws.Range("C2:E" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 1)) For i = 1 To UBound(Arr, 1) If Arr(i, 3) = Tgrt Then p = p + 1 Tmp(p, 1) = Arr(i, 2) & Arr(i, 1) Reslt = Reslt & "" & Tmp(p, 1) End If Next ws.Range("I3") = Reslt End Sub

شكرا استاذ موسى على الملاحظات ..ربما لم اضعها Double لان عملتنا ليس فيها فواصل اما تكرار الشهر نفسه فالعتب على النظر ولم افرق بين 1 وال i ☺️ المرفق بعد التعديل testQ.rar

تفضل أخي حصلت عندي هذا أنشاء وحذف مجلد ووافني بالرد IMAGE (Khalifa).rar

كما العنوان ، رسم Lines و Borders/Frames لتقارير الأكسس ، نسخة أولى تجريبية أنا مجهد وسأعود الليلة أو غدا للكتابة عن بعض التفاصيل وحيثيات التصميم والعراك مع برمجة المثال. اكتبوا ملاحظاتكم وطلب خاص مني وبشكل مؤقت ، لا ترفعوا نسخا معدلة ، فقط ضعوا ملاحظاتكم. وشكرا لكم. من ميزات المثال: أنه لا يجبر المبرمج على استخدام الرسم على كل حقول التقرير. أنه يتعامل مع عرض الخط/الإطار حسب الخصائص. أنه يتعامل مع لون الخط/الإطار حسب الخصائص. ومن عيوبه: قد يكون بطيئا عند كثرة البيانات وعدد الصفحات لفتح التقرير مرتين لزوم الحصول على بعض بيانات النسيق. عندي أفكار أخرى سأؤجلها حتى أرى مثال الأخ العزيز جعفر فقد أكتفي أو أقوم ببعض التحسينات بالاستفادة من مثاله. ملاحظات: العمل في هذا المثال أضافت إلي معلومات جديدة لأول مرة وهذا طبيعي فلم تكن لي حاجة بها قبل هذا المثال. DrawLinesAndBoxes4AccessReports_01.accdb

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

أخي تأكد من المكتبات لديك لانه يعمل عندي ومافيه مشاكل

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

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

تفضل أخي شرح وافي

سلم عليكم حبيت اضيف لمسات على الملف اخوي /محمد التميمي تفضل سجل سنوي.xlsm

بدل ان نجعل مصدر بيانات حقل الترقيم =1 ، اجعله =25 ، وهو اول عدد يتم به الترقيم ، وطبعا علشان يتم الترقيم ، لازم يكون عندنا Running Sum على مستوى المجموعة او مستوى التقرير كاملا : . جعفر

مهندسنا العزيز 🙂.. من الملاحظات على المرفق .. 1ـ الأرقام من نوع Integr. يحتاج تكون Double أو عملة علشان تقبل الفواصل .. الحين البرنامج يقربها فيطلع المجموع بالزيادة .. 2ـ التاريخ ما يزيد شهر في الأقساط .. يضل يكتب تاريخ أول قسط ..

أخي أنا حصلت عندي برنامج أقساط يمكن ينفعك ووافني بالردBou-Tariq Installments Program1.rarBou-Tariq Installments Program1.rarBou-Tariq Installments Program1.rarBou-Tariq Installments Program1.rar Bou-Tariq Installments Program1.rar

حصلت لدي برنامج يمكن ينفعك ووافني بالرد Bou-Tariq Installments Program1.rar

عليكم السلام والرحمة عسى يكون المطلوب مع ملا حظة أن الدرس السادس كما لا حظت فارغ دائما وإلا الكود لن يعمل إذا ولا بد اعلمني للتعديل ايجاد كود للتوزيع.xlsm

وعليكم السلام ورحمة الله وبركاته 🙂 تفضل يا سيدي ، دالة تحذف المجلد واللي فيه : Function DelFolder(ByVal strDir As String) As Long On Error Resume Next ' to delete the directory and its contents Dim x As Long Dim intAttr As Integer Dim strAllDirs As String Dim strFile As String DelFolder = -1 strDir = Trim$(strDir) If Len(strDir) = 0 Then Exit Function If right$(strDir, 1) = "\" Then strDir = Left$(strDir, Len(strDir) - 1) If InStr(strDir, "\") = 0 Then Exit Function intAttr = GetAttr(strDir) If (intAttr And vbDirectory) = 0 Then Exit Function strFile = Dir$(strDir & "\*.*", vbSystem Or vbDirectory Or vbHidden) Do While Len(strFile) If strFile <> "." And strFile <> ".." Then intAttr = GetAttr(strDir & "\" & strFile) If (intAttr And vbDirectory) Then strAllDirs = strAllDirs & strFile & Chr$(0) Else If intAttr <> vbNormal Then SetAttr strDir & "\" & strFile, vbNormal If Err Then DelFolder = Err: Exit Function End If Kill strDir & "\" & strFile If Err Then DelFolder = Err: Exit Function End If End If strFile = Dir$ Loop Do While Len(strAllDirs) x = InStr(strAllDirs, Chr$(0)) strFile = Left$(strAllDirs, x - 1) strAllDirs = Mid$(strAllDirs, x + 1) x = DelFolder(strDir & "\" & strFile) If x Then DelFolder = x: Exit Function Loop RmDir strDir If Err Then DelFolder = Err Else DelFolder = 0 End If End Function جعفر

اسف استاذ احمد لتاخري عليك بسبب المشاغل عملت لك جدولين ..جدول للموظفين او الزبائن وجدول القروض افتح النموذج EmployeeF ولاحظ ان الاقساط تتوزع بناء على تاريخ اول قسط وعدد الاقساط وعندما تغير حالة الدفع سوف تتغير لديك المبالغ المدفوعة والمتبقية بالتوفيق testQ.rar

اخي هناك فكرة قد تم تناولها مع احد الاخوة سابقا في احد المواضيع ربما تسهل عليك عملية التلوين بما ان الكلمات و الحروف مكررة يمكنك استخدام كود ينوب عنك في هده المسالة فقط ادخل اوقم بنسخ الكلمة او الحرف المطلوب في الخلية (F2) بنفس الشكل المكتوب به مثال : ( فَبَشِّرْهُم) لا يمكن كتابتها (فبشرهم) وسوف يتم تلوين جميع الكلمات دفعة واحدة مع الاحتفاظ بالتنسيق ..كما يمكنك تعديل رقم اللون المطلوب داخل الكود للون المطلوب كما في الصورة تحت Sub ChangeColor2() 'البحث في عمود("a") Application.ScreenUpdating = False Dim Rng As Range Dim MH As String Dim MH2 As String Dim x As Long Dim m As Long Dim y As Long Dim xFNum As Integer Dim xArrFnd As Variant Dim xStr As String MH = Range("F2").Value If Len(MH) < 1 Then Exit Sub xArrFnd = Split(MH, ",") ''' قم بتحديد النطاق المطلوب '''''' Range("A1:A100000").Select For Each Rng In Selection With Rng For xFNum = 0 To UBound(xArrFnd) xStr = xArrFnd(xFNum) y = Len(xStr) m = UBound(Split(Rng.Value, xStr)) If m > 0 Then MH2 = "" For x = 0 To m - 1 MH2 = MH2 & Split(Rng.Value, xStr)(x) '3= اللون الاحمر 'قم باستبدال الرقم 3 برقم اللون المطلوب .Characters(Start:=Len(MH2) + 1, Length:=y).Font.ColorIndex = 3 MH2 = MH2 & xStr Next End If Next xFNum End With Next Rng Range("F2").Select Application.ScreenUpdating = True End Sub قائمة الالوان اختر اللون المناسب وقم باستبداله داخل الكود في حالة تعدر عليك الامر يمكنك رفع الملف للتعديل فسوف نكون سعداء بمساعدتك في هدا العمل الطيب (فخِدْمَةَ الْقُرْآنِ مِنْ خَيْرِ الْأَعْمَالِ وَأَشْرَفِهَا، وَأَعْظَمِ الْقُرُبَاتِ وَأَعْلَاهَا، فَهُوَ خَيْرُ دَارٍ، وَحَسَنَاتٌ جَارِيَةٌ لِصَاحِبِهِ، حَيًّا وَمَيِّتًا.) ووفقنا الله واياكم اخي لما يحب ويرضى 4.xlsm

الكود لا يضر الموقع ولا يظهر عندهم الكود يقوم بما يقوم به المستخدم ولكن بصورة آلية تحتاج قبل البدء معرفة ID حقل اسم المستخدم وكذلك كلمة المرور وكذلك زر الدخول وبعدها ID لكل حقل سيتم تعبئته من الشيت وكل زر سيتم الضغط عليه لمعرفة ID لعنصر نضغط بزر الفارة الأيمن على العنصر في المتصفح ونختار inspect element وبعدها نستخدم كود انشاء نسخة من كائن متصفح انترنت اكسبلورر بمثل هذا الكود Dim IE As Object, site as String Set IE = CreateObject("InternetExplorer.Application") site = "https://www.example.com/" With IE .Visible = True .navigate site Do Until Not IE.Busy And IE.readyState = 4 DoEvents Loop End With IE.Document.getElementById("username").Value = range("aa1").value IE.Document.getElementById("password").Value = range("ab1").value IE.Document.getElementById("login_go").Click Do Until Not IE.Busy And IE.readyState = 4 DoEvents Loop وهكذا في كتابة قيم الحقول من الشيت نستعمل حلقة تكرارية مثل for - next وهكذا الضغط على اي زر لحفظ البيانات مثلا بالتوفيق