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

استبدل الكود بهذا أخي الكريم Public Function re_Num() Dim rst As DAO.Recordset Dim i As Long Dim RC As Long Set rst = CurrentDb.OpenRecordset("Select * From b14") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 0 To RC - 1 rst.Edit rst!HNO = 1 + i rst.Update rst.MoveNext Next i rst.Close: Set rst = Nothing MsgBox "Done" End Function

تفضل هذه المحاولة ارجو ان تكون موفقة jo2.rar

تفضل هذا التعديل Microsoft Access قاعدة بيانات جديد (2).rar

تفضل هذا التعديل اخي الكريم DATA20001.rar

جرب المرفق ..... واعلمنا هل تغيرت السرعة أم لا .... سجلات 01.accdb

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

اعتذر استاذ abdhamid لان فهمت الموضوع بصورة غير صحيحة تفضل التعديل ارجو ان يكون طلبك ملاحظة : يجب ان يكون عدد السجلات مساوي لعدد الصور لان لم اضع شرط عدم التساوي لحين التاكد من عمل الكود الكود منقول من احد المواقع emp3.rar

تفضل ... DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE b14 SET b14.hno = DCount(""*"",""b14"",""ID <="" & [ID]);" DoCmd.SetWarnings True

الإخوة الكرام .. في الملف المرفق استعلام لإعادة ترقيم حقل (HNO) بترقيم متسلسل والمطلوب القيام بهذه العملية من خلال كود في النموذج على شاكلة DoCmd.RunSQL "UPDATE .. لاستعماله ضمن أكواد أخرى عند اللزوم ثم لا حظت أن هذا الاستعلام يعمل ببطء شديد في الملفات الكبييييرة فهل توجد صيغة أخرى أكثر سرعة تؤدي المطلوب .. سواء كاستعلام أو كود سجلات 01.rar

استاذنا الفاضل حسام ظهرت لى مشكلة عندما اردت تصنيف الصور فى مجلدات واختيار مجلد ما ظهرت لى رسالى خطا subscribe out of range والخطا فى سطر For i = LBound(aFiles) To UBound(aFiles) ارجو الافادة اعلم انى اثقلت عليكم emp3.rar

تسلم من كل شر ربنا يجعل مساعدتك لى فى ميزان حسناتك

استاذنا الفاضل حسام ظهرت لى مشكلة عندما اردت تصنيف الصور فى مجلدات واختيار مجلد ما ظهرت لى رسالى خطا subscribe out of range والخطا فى سطر For i = LBound(aFiles) To UBound(aFiles) ارجو الافادة اعلم انى اثقلت عليكم emp3.rar

السلام عليكم ورحمة الله وبركاته، كيف حالكم اخواني الأفاضل. مبارك عليكم حلول شهر رمضان المبارك أعاده الله علينا وعليكم باليمن والخير والبركات. اقدم لكم فنكشن لإحتساب المدة بين تاريخين سنة - شهر - اسبوع - ساعة - دقيقة - ثانية سؤال: ما الفائدة من هذا الفنكشن؟ بالدرجة الأولى سيُفيد أصحاب برامج الأقساط والتقسيط لإحتساب فترات التأخير والإستحقاق وغيرها. وربما هنالك استخدامات أخرى له، حسب احتياج كل شخص الفنكشن: Public Function MainElapsedTime(d1, d2) As String d1 = CDate(d1) d2 = CDate(d2) vSecs = DateDiff("s", [d1], [d2]) MainElapsedTime = ElapsedTimeAsTextRecur(vSecs) End Function Public Function ElapsedTimeAsTextRecur(ByVal pvSecs, Optional ByVal pvSecBlock) 'recursive time lapse given seconds Dim vTxt Dim iNum As Long Const kDAY = 86400 Const kSECpYR = 31536000 '60 sec = 1 min = 60 sec '60 min = 1 hour = 3,600 sec '24 hour = 1 day = 86,400 sec '07 days = 1 week = 604,800 sec '30 days = 1 month = 25,92,000 sec '12 months = 1 year = 31,536,000 sec 'YEARS If IsMissing(pvSecBlock) Then pvSecBlock = kSECpYR iNum = pvSecs \ pvSecBlock Select Case pvSecBlock Case kSECpYR 'yr sUnit = "years" If iNum > 0 Then vTxt = iNum & " Years " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 2592000) Case 2592000 'MO sUnit = "months" If iNum > 0 Then If iNum > 11 Then iNum = 11 vTxt = vTxt & iNum & " Months " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 604800) Case 604800 'WEEK sUnit = "weeks" If iNum > 0 Then If iNum > 3 Then iNum = 3 vTxt = vTxt & iNum & " Weeks " pvSecs = pvSecs - (iNum * kDAY * 7) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 86400) Case kDAY 'day sUnit = "days" If iNum > 0 Then vTxt = vTxt & iNum & " Days " pvSecs = pvSecs - (iNum * kDAY) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 3600) Case 3600 'hrs sUnit = "hrs" If iNum > 23 Then iNum = 23 If iNum > 0 Then vTxt = vTxt & iNum & " Hours " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 60) Case 60 'min sUnit = "mins" If iNum > 0 Then vTxt = vTxt & iNum & " Minutes " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 1) Case Else sUnit = "secs" If pvSecs > 0 Then vTxt = vTxt & pvSecs & " Seconds" End Select ElapsedTimeAsTextRecur = vTxt End Function الإستخدام بسيط جدا في الإستعلامات او في النماذج او التقارير كالآتي: MainElapsedTime("Here your date", Date()) --------------------------------------------------- Example: MsgBox MainElapsedTime("6/3/2020", "14/4/2021") النتيجة: هنا انا قمت بمقارنة تاريخين فقط بدون أوقات، سأقوم الآن بمقارنة تاريخ مع وقت MsgBox MainElapsedTime("2/02/2019 12:07:16 pm", "13/04/2021 1:08:6 am") النتيجة: للأمانة الكود ليس من كتابتي 100%، فقط انا قمت بالتعديل عليه ليصبح بشكل افضل.. تحياتي وانتضرو مفاجئتي في الموضوع القادم

ممكن ان يكون المطلوب ASD200.xlsm

الف شكر

عليكم السلام والرحمة تفضل التعديل ارجو ان يكون طلبك ملاحظة : الكود يراعي يومي السبت والاحد فقط كعطل رسمية اما بقية العطل فيجب تحديدها وبعد معرفة كفاءة الكود يتم تعديل الكود على اساسها Reorder.rar

جزيت خيرا تمام

تفضل Sub RectangleRoundedCorners222_Click() 'On Error Resume Next 'Sheets("ÍÓÇÈ").Range("A1:h10").ExportAsFixedFormat xlTypePDF, Filename:="e:\pdf\" & Sheets("ÍÓÇÈ").Range("b3").Value & Sheets("ÍÓÇÈ").Range("a3").Value, openafterpublish:=True Dim sh As Worksheet Dim R Dim fil_name Set sh = ThisWorkbook.Worksheets("حساب") fil_name = sh.Range("b3") & " " & sh.Range("a3") Set R = sh.Range("a1:h10") R.ExportAsFixedFormat Type:=xlTypePDF, Filename:="e:\pdf\" & "\" & fil_name sh.Range("a1:h29").PrintOut End Sub

اعتذر لان ذهب الى فولدر E ولم اجد الحفظ ولكن وجدته على سطح المكتب ممكن يكون الحفظ على نفس المسار فولدر E - ملف PDF

جربته ويعمل 100/100 وهذه نسخة من التخزين حسين 91.pdf

جرب هذا الكود يخزن نسخة في نفس فولدر لي فيه الملف Sub RectangleRoundedCorners222_Click() 'On Error Resume Next 'Sheets("ÍÓÇÈ").Range("A1:h10").ExportAsFixedFormat xlTypePDF, Filename:="e:\pdf\" & Sheets("ÍÓÇÈ").Range("b3").Value & Sheets("ÍÓÇÈ").Range("a3").Value, openafterpublish:=True Dim sh As Worksheet Dim R Dim fil_name Set sh = ThisWorkbook.Worksheets("حساب") fil_name = sh.Range("b3") & " " & sh.Range("a3") Set R = sh.Range("a1:h10") R.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & fil_name sh.Range("a1:h29").PrintOut End Sub

اها صحيح السبب اني غيرت نوع عمود رقم الفاتورة من النصي الى الرقم فاختلف معيار التعديل في الحقول تفضل التعديل DATA20002.rar

تم تعديل اسماء الضفحات الى Reg اي Region وذلك من اجل حسن نسخ الكود ولصقه دون مشاكل اللغة العربية وطهور أحرف غريبة فيه فقط اضغط الزر Run Option Explicit Sub All_In_One() Dim SH(), itm, My_sh As Worksheet Dim T As Worksheet Dim Ro%, Sb#, Sc#, Sd#, Se#, Sf#, Sg#, k%, n% Dim ads% Dim F_rg As Range, Wat Set T = Sheets("Total") k = T.Cells(Rows.Count, 1).End(3).Row If k < 3 Then Exit Sub T.Range("B3").Resize(k - 2, 6).ClearContents SH = Array("Reg1", "Reg2", "Reg3", "Reg4", "Reg5") For n = 3 To k Wat = T.Range("A" & n) For Each itm In SH Set My_sh = Sheets(itm) Ro = My_sh.Cells(Rows.Count, 1).End(3).Row If Ro < 3 Then GoTo Next_Itm Set F_rg = My_sh.Range("A2:A" & Ro).Find(Wat, Lookat:=1) If F_rg Is Nothing Then GoTo Next_Itm ads = F_rg.Row Sb = Sb + Val(My_sh.Cells(ads, "B")) Sc = Sc + Val(My_sh.Cells(ads, "C")) Sd = Sd + Val(My_sh.Cells(ads, "D")) Se = Se + Val(My_sh.Cells(ads, "E")) Sf = Sf + Val(My_sh.Cells(ads, "F")) Sg = Sg + Val(My_sh.Cells(ads, "G")) Next_Itm: Next itm With T.Cells(n, 2) .Value = Sb: Sb = 0 .Offset(, 1) = Sc: Sc = 0 .Offset(, 2) = Sd: Sd = 0 .Offset(, 3) = Se: Se = 0 .Offset(, 4) = Sf: Sf = 0 .Offset(, 5) = Sg: Sg = 0 End With Next n End Sub الملف مرفق Hasan.xlsm

تفضل هذه المعادلة لكود المندوب =IFERROR(INDEX(المناديب2!$A:$A,MATCH($A2,المناديب2!$B:$B,0)),"") وهذه المعادلة لكود السيارة =IFERROR(INDEX(' السيارات3'!$A:$A,MATCH($C2,' السيارات3'!$C:$C,0)),"") حركه السيارات.xlsx

تفضل التعديل حسب فهمي لطلبك emp2.rar

في الخلية B3 من الصفجة (اجمالي يومي) اكتب هذه المعادلة( كما في الصورة) ثم اسحب يساراً 6 اعمدة و نزولا حتى الصف 89 الملف مرفق Hasan.xlsx

خالص الشكر والدعاء من القلب لك اخى فى الله استاذ د.كاف يار انا نسخت جزء من البيانات فى الجدولtbl_Items ممكن حضرتك تجرب استدعاء الفاتورة1732 ستجد البيانات غير خالص البيانات ولا جتى ترتيب اشكرك بارك الله فيك ولك وبك يارب DATA2000.rar

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته اخوتي / اخواتي لي الشرف ان انظم الى هذا الصرح العلمي ، سائلاً المولى جل وعلا ان يوفقني لما فيه الخير للجميع 🙂 في اول مشاركة لي ، اضع بين يديكم برنامج مسقط التقارير (مسمى صانع التقارير متداول كثيرا ، لذا احببت ان اسمي برنامجي بإسم مميز ، إسم مسقطنا الحبيبة 🙂 ). البرنامج في نسخته الاولى ، لذا ، فلا تتوقعوا الكثير منه 🙂 في احد المشاريع التي عملت عليها قريبا ، كان العمل لسجلات شؤون الموظفين ، ولم يكن بالامكان عمل تقرير محدد ، حيث كانت التقارير المطلوبة من الادارة بشتى انواع البيانات ، طولا وعرضا. لذا اضطررت العمل على صانع للتقارير (في الواقع مسقط التقارير يعتبر برنامجا بحد ذاته ، فالعمل كان ، برنامج في برنامج 🙂 ). مع ان البرنامج بسيط في طريقة عمله (وطبعا عندي الكثير من الاشياء الاخرى التي اود ان اضيفها ، لكن في وقتها ان شاء الله ، وبما ان البرنامج مفتوح المصدر ، فانا ارحب بمن يضيف عليه خصائص جديدة 🙂 ) ، فمع بساطة البرنامج ، إلا ان نتائجه مرضية 🙂 العمل على البرنامج ابسط بكثير من شرحه 🙂 يمكنك نقل هذه الكائنات السته الى برنامجك الخاص ، ومسقط التقارير سيعمل بدون الحاجة الى اي تغيير او كود: مسقط التقارير يعمل على الجداول والاستعلامات فقط ، واليكم طريقة العمل: جدول او استعلام: اختر من ايهم تريد ان تعمل تقريرك ، جدول او استعلام ، الاسم: على اساس الاختيار السابق ، ستظهر لك قائمة بجداولك او استعلاماتك ، وعندما تختار اسم جدول او استعلام ، فان النموذج الفرعي الذي اسفل الاسم سوف يمتلئ باسماء الحقول من الجدول او الاستعلام ، وكلها عليها اشارة اخفي (اي كلها ستكون مخفية من الظهور في النموذج الفرعي الذي بالاسفل) ، احذف اشارة الاخفاء عن الحقول/الخانات التي تريدها ، وستظهر لك في النموذج الفرعي الذي في اسفل النموذج. هذا النموذج هو شكل مبسط من التقرير ، فكما ترى الحقول وعرضها ، وعدد السجلات ، ستراها في التقرير. هناك خطان فوق النموذج الفرعي ، باللون الاصفر والاخضر ، اذا كانت بياناتك اقل من الخط الاصفر ، سيكون التقرير بالطول ، وإلا فانه سيكون بالعرض ، وهناك خطان صفر ، فالمسافة بينهم ستكون للترقيم التلقائي للتقرير (لاحظ ان التقرير لبيانات النموذج ادناه سيكون بالعرض ، لأننا تخطينا الخط الاصفر 🙂 يمكننا ان نمسك الحقول/الخانات بالزر الايسر من الفأرة ونغير ترتيبها يمينا ويسارا ، كما ان البرنامج يحترم عرض الحقل الذي تقوم بتعديله ، (لاحظ ان التقرير لبيانات النموذج سيكون بالطول ، لأننا في حدود الخط الاصفر 🙂 وهذا هو التقرير لبيانات النموذج السابق ، ولاحظ ان البرنامج يقوم بتغيير ارتفاع الصف تلقائيا ، حتى يمكن مشاهدة جميع بيانات الحقل. اذا قررت ان تتعدى الخط الاصفر ، فنفس شروط الخط الاصفر تنطبق على الخط الاخضر ، وهنا نرى باننا اضفنا عنوان لراس صفحة التقرير ، واضفنا معلومات عن موضوع التقرير ، بالاضافة الى معلومات في ذيل التقرير: وهذا هو تقرير لبيانات النموذج السابق ، ولاحظ ان البرنامج يوسع عمود الترقيم التلقائي ليسد المسافة: بعد اختيار الحقول التي نريدها في التقرير ، نستطيع ان نفرز الحقول بالطريقة التي نريد: وكذلك تصفية البيانات حسب الحاجة: وهذا هو تقرير لبيانات النموذج السابق ، لاحظ عدد السجلات قد تغير ، لأني طلبت ان ارى السجلات التي مبالغها اكبر من 500: البرنامج لا يحفظ التقارير (نعم ، عمل طريقة لحفظ اسم لكل تقرير ، على قمة قائمة التحديثات ان شاء الله 🙂 ) ارجوا ان تتقبلوا مني هذا العمل المتواضع 🙂 اسئلة/اقتراحات ، سأحاول الرد على قدر استطاعتي ان شاء الله 🙂 جعفر ملاحظة1: عمود المجموع لا يعمل ، وكان يجب ان اخفيه 😞 ملاحظة2: في الاساس كان عندي كمية كبيرة من صور الشرح ، إلا ان المنتدى لا يسمح بأكثر من 10 مرفقات ، فاختزلت الموضوع 🙂 ملاحظة3: ادراج فيديو لطريقة عمل التقرير: Muscat_Reports.zip

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