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

السلام عليكم اعضاء الكنترول الكرام اضع بين ايديكم شيت كنترول جدارات _ قسم حاسبات " الصف الاول "_ مفتوح المصدر يشتمل على ♦ شيت الرصد ♦ شهادات التيرم الاول ♦ شهادات نهاية العام ♦ تحديد الاوائل في الشهادة " هذا العمل خالصا لوجه الله تعالى " hasbat_1_gdarat.xlsm

اختيار من متعدد بطريقة جديده multiselectform.accdb

اعتقد هذا طلبك Update Prog.mdb

سأرفق لك فكرة قد تعجبك فانتظرني 😅

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي حاولت تنفيدها بطريقة اخرى لتكون النتائج ادق وعدم تسبب المعادلات بثقل للملف زيادة على غياب تطابق عناوين الاعمدة على الجداول ودالك بتحويل المعادلات الى اكواد ووضع لكل يوم كود معين يتم تنفيده بشرط قيمة الخلية S3 ملاحظة 1) لقد قمت بحدف المغادلة الخاصة بجلب اسم اليوم من التاريخ في الخلية S3 ووضعت قائمة منسدلة تتضمن الايام من الاحد الى الخميس عند اختيارك اليوم المناسب يتم جلب بياناته تلقائيا 2) تم الاستغناء على معادلة الترقيم التلقائي للبيانات في عمود A واستبدالها بالاكواد 3) يتم تنفيد الكود المناسب عند التغيير في عمود الاسماء تلقائيا الكود الخاص بيوم الاحد للتوضيح Sub Sunday() Dim F1$, F2$, F3$, F4$, F5$, F6$, F7$, F8$, A$, B$, J% Dim MyRng As Range, MyDst As Range, Title As Range, R As Range, D As Range Dim MyDest As Worksheet: Set MyDest = Feuil1 Dim MyData As Worksheet: Set MyData = Feuil2 A = MyDest.Name B = MyData.Name Set C = MyData.Range("$D$4:$M$24") Set D = MyDest.Range("A22:A31") Set Title = MyDest.Range("B22:B31") Set MyRng = MyDest.Range("F22:U31") Application.ScreenUpdating = False MyDest.Unprotect "0000" D.ClearContents With MyDest F1 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",2,0),"""")" F2 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",4,0),"""")" F3 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",5,0),"""")" F4 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",6,0),"""")" F5 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",7,0),"""")" F6 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",8,0),"""")" F7 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",9,0),"""")" F8 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",10,0),"""")" [F22] = F1: [H22] = F2: [J22] = F3: [L22] = F4: [N22] = F5: [P22] = F6: [R22] = F7: [T22] = F8 .Range("F22:U22").AutoFill Destination:=.Range("F22:U31"), Type:=xlFillDefault MyRng.Value = MyRng.Value For Each R In Title If R.Value <> Empty Then J = J + 1 R.Offset(0, -1).Value = Format(J, "0") End If Next MyRng.Replace 0, "", xlWhole End With MyDest.Protect "0000" End Sub الكود الخاص بتنفيد الكود المناسب عند التغيير في خلية اليوم Sub Results() Select Case Range("S3") Case "الأحد": Sunday Case "الاثنين": Monday Case "الثلاثاء": Tuesday Case "الأربعاء": Wednesday Case "الخميس": Thursday End Select End Sub مع وضع الكود التالي في Worksheet.Change الورقة 1 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("B22:B31")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True Exit Sub End If If Not Intersect(Target, Range("S3")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True End If On Error GoTo 0 End Sub التقرير اليومي مبرمج 2023.xlsm

اخواني هل يوجد خطاء في كود الترحيل و التعديل و البحث و فاتورة جديدة فاتورة كاملة.xlsm

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

تفضل BAZEG.accdb

ولك بالمثل أخي @محمد احمد لطفى

مش حاجة بل حاجات lab2.rar

لو هتعمل جدول للمهن و قاعات خاصة لكل مهنة الكود هيتغير للتالى =Nz(DLookUp("[room]";"[جدول2]";"[Grade]='" & [Grade] & "'");"") فقط قم باضافة المهن فى جدول 2 ووضع ارقام القاعات تم عمل الملف فى مشاركة سابقة BASEZ (1) (1).accdb

جزاك الله خيراً أستاذى @Foksh

نعم ان شاء الله

تفضل =IIf([grade]="طبيب";"25";IIf([grade]="مهندس";"25";Nz(DLookUp("[room]";"[جدول1]";"[Grade]='" & [Grade] & "'");""))) BASEZ (2).accdb

يتم تحديثه فعلا بعد الاضافة والحفظ انظر في الشجرة

بارك الله فيك أخي الكريم وربي يجازيك هذا هو المطلوب بالتفصيل ممكن سؤال آخر غير هذا لنفرض حقل Room موجود في جدول1 وحقل Grade موجود في جدول 2 كيف يمكن عمل نفس الشئ و مع وظيفيتين معا: طبيب و مهندس وبارك الله فيك أخي

اتمنى اني اكون فهمت صح 😅 تفضل هذه الفكرة Prog.accdb

تفضل BASEZ.accdb

ربي يعطيك الخير أخي الكريم المشكلة من عندي وكانت في الجداول المرتبطة ربي يزقك من حيث لا تحتسب

ممكن تكتب الكود هنا 🙂

سأتحقق من موضوع المكتبة واتابع معك كاضافه مني جرب هذا الملف المرفق واتمنى ايجاد الغايه فيه ولو حتى بجزء بسيط. وتذكر اني لا اقوم بتجربة المرفق ولا الأكواد لانني لست امام جهاز الكمبيوتر. 08 MS access - scan and attach documents -Scand and convert to PDF.accdb

اكتب الكود في مصدر مربع النص الخاص بالتاريخ في التقرير ، بشرط أن لا يكون تنسيق المربع بالـ Format <> Short Date و يفضل ان يكون التنسيق فارغاً من أي صيغة. وإذا كان مصدر التقرير ناتج عن نموذج فضع الكود في مربع النص التابع له التاريخ ، واجعل مصدر الحقل في التقرير يكون نفس الحقل في النموذج. واعتذر لعدم وجود تطبيق كمرفق لأني لست أمام الكمبيوتر حالياً.

التجربة الثانية ولن نخسر شيء 😅 Private Sub CommandButton_Click() Dim scanner As WIA.CommonDialog Dim img As WIA.ImageFile Dim pdf As Object ' إنشاء مربع حوار الماسح الضوئي Set scanner = New WIA.CommonDialog Set img = scanner.ShowAcquireImage() ' تصدير الصورة إلى ملف PDF باستخدام مكتبة Adobe PDF Set pdf = CreateObject("AcroExch.PDDoc") pdf.Create pdf.AddPage pdf.Save ("C:\مسح.pdf") ' إغلاق المسح الضوئي Set scanner = Nothing End Sub

من خلال البحث وجدت هذا الكود ، ولم أقم بتجربته لعدم وجود ماسح ضوئي عندي. Private Sub ScanAndSaveAsPDF_Click() Dim WIA_Devices As Object Set WIA_Devices = CreateObject("WIA.DeviceManager") If WIA_Devices.DeviceInfos.Count > 0 Then Dim WIA_Device As Object Set WIA_Device = WIA_Devices.DeviceInfos(1).Connect Dim WIA_ImageFile As Object Set WIA_ImageFile = WIA_Device.Items(1).Transfer Dim filePath As String filePath = "C:\Path\To\Save\ScannedDocument.pdf" WIA_ImageFile.SaveFile filePath ' إجراءات إضافية إذا كنت بحاجة، مثل فتح ملف PDF أو حفظ معلوماته في قاعدة البيانات Else MsgBox "لم يتم العثور على جهاز ماسح ضوئي." End If End Sub

احسنت هو كذلك

أخي وأستاذي الفاضل @شايب وإني فوق الإحترام الذي أكنه له كشخص فإني أساويه بإحترامي لرأيك ، وما كنت ولن أجرؤ على الإحراج ( وحاشا لله أن أقصده لأي شخص ) ، وما كان من الفيديو المقصود هو أن الويندوز يدعم فكرة الـ Downgrade بين معظم منتوجاته وأعتقدت للحظة أنها ثغرة كانت في الإصدارات القديمه أنها لا تقوم بكشف ما إذا كان هناك نسخة من نفس المنتج بإصدار آخر ، إلا أنها كشركة أنتبهت لذلك في العهد الحديث من تطبيقاتها ،، ليس إلا. كل الإحترام لشخصك الطيب أستاذي الشايب. (هو مجرد رأي ليس إلا)

الف الف مليون تريلون مبرووووك للجميع

جلست على المثال فترات طويلة المشكلة التي واجهتها انه لا يتم الاتصال بالماسح من خلال الكود .. رغم ان يتصل من خلال البرنامج i_view64.exe على كل حال بالنسبة للحفظ هل جربت مثل هذا : Dim mypath mypath = CurrentProject.Path & "\My_Archive\Import\My_pdf\" Shell ("c:\Program Files (x86)\irfanview\i_view32.exe /batchscan=(ahmed,1,1,2,0,mypath,pdf,1) /scanhidden") اعتذر اخي كنت تمنيت ان الكود عمل يبدوا ان النظام له يد في ذلك

تأكد من المجلد backup بنفس مسار قاعدة البيانات التي تم النسخ إليها , مع أن الملف يعمل جهاز آخر بعد تجربته . شرط آخر بعد الأول في حال وجود خطأ في أخذ النسخة ( لأي سبب كان ) فإن الرد سيكون ( حدث خطا ما ، لم يتم اخذ نسخه احتياطية ) واذا استمرت المشكلة في القاعدة الثانية أرسل منها جزء مرفق لمعالجة الخطأ

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

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

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

للأسف يا صديقي ، انا عندي على كمبيوتري في العمل ما يلي :- نظام تشغيل ويندوز 10 بنواة 64 نسخة من مايكروسوفت أوفيس 2016 بنواة 64 بواجهة أنجليزية ( تم تثبيته أولاً ) نسخة من مايكروسوفت أوفيس 2010 بنواة 32 و واجهة عربية أيضاً ( تم تثبيته بعد تثبيت السابق ) هذه نسخة الـ 64 بت أوفيس 2016 وفيما بعد نسخة 32 واجهة عربية أوفيس 2010

أوافق أخي @شايب معلوماته ، ولكني أعتقد ان الأمر لا ينطبق على نسخة الويندوز الـ 64 !! فعلى جهازي فعلياً ( نسختين أوفيس 32 = 2010 + 64 = 2016 ) ، على نسخة ويندوز 64 . وفي مشاركة أخرى للأستاذ @jjafferr ، واقتبس منها في هذه المشاركة :- بغض النظر عن نظام الويندور ( لا أعلم أن كان المقصود بكلامه هو 32 و 64 ، أو Win10 و Win7 ، .... الخ ) . لكن بالعودة للموضوع فأعتقد إنه نظام التشغيل الـ 64 هو أشمل وأوسع نظاقاً بالنسبة لقبوليته البرامج .

آخر صف يتم حسابه على العمود A والصواب العمود B لأن A فارغ يمكنك تغيير هذا السطر lr = .Cells(.Rows.Count, "A").End(xlUp).Row إلى lr = .Cells(.Rows.Count, "B").End(xlUp).Row ولا يقوم الكود بحذف المصدر بالتوفيق

هكذا؟ Sub Triage() With ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2") .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("Tableau2[Date Echeance]") .Sort.SortFields.Add2 Key:=Range("Tableau2[Client]") With .Sort .Header = xlYes .Apply End With End With End Sub

ربما يكون هذا هو المطلوب بالتوفيق test1.xlsx

تم عمل المطلوب عملت جدول فرعي مرتبط بمعرف المستخدم ، ثم كود برمجي لنسخ تسميات الحقول الى هذا الجدول لجميع المستخدمين المسجلين ---------------------------------------- طبعا المثال لا يحتوي على آلية لتعيين المستخدم وانما يتم ذلك في برنامجك عند بدء فتح البرنامج لذا عملت شيئا من هذا القبيل في النموذج لتعيين مستخدم محدد كي نشاهد نتيجة العملية ------------------------------------- تطبيق الفكرة سهل ويسير فقط تتبع الخطوات من خلال النماذج نبدأ من نموذج الإعداد / ثم نموذج الخيارات / ثم النتيجة في نموذج عرض البيانات آمل ان يحوز على رضاك ويلبي طلبك ،،، Data2.rar

وعليكم السلام ورحمة الله جرب الكود التالى Dim ws As Worksheet: Set ws = Sheets(1) Dim sh As Worksheet: Set sh = Sheets(2) sh.Range("A5:N1000") = "" k = 5 lr = ws.Range("A" & Rows.Count).End(xlUp).Row For i = 3 To lr Dim columns(1 To 3) As Variant columns(1) = "J" columns(2) = "L" columns(3) = "N" For c = 1 To 3 Dim column As String column = columns(c) If ws.Range(column & i) >= sh.[D2] And _ ws.Range(column & i) <= sh.[G2] Then For j = 2 To 20 sh.Cells(k, j) = ws.Cells(i, j) Next k = k + 1 End If Next c Next i

هذا ملف ادعو الله ان يجزي بالخير كل من ساعد علي ظهوره برنامج بسيط لشئون العاملين رقم الدخول 1111 شئون+العاملين+2016.rar

اولا عمل العديد من CheckBox كل عليك عملة هو الضغط علي الزر وتحديد المدي المراد عمل له ال CheckBox شاهد المرفق Create_CheckBoxes.xlsm ثانيا عمل العديد من OptionButton كل عليك عملة هو الضغط علي الزر وتحديد المدي المراد عمل له ال OptionButton شاهد المرفق Create_OptionButtons.xlsm

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

اولا ضع الكود الاتى فى وحدة نمطية Public Function ChnageDateFormat(Optional dtDateFormat As String = "dd/MM/yyyy") Shell "cmd.exe /c REG ADD ""HKEY_CURRENT_USER\Control Panel\International"" /v sShortDate /d """ & dtDateFormat & """ /F", vbHide End Function ثانيا طبق الكود الاتى بعد اسنخدام الاداة فى قاعدتك التى اشرت اليها بذلك تتخطى عقبة تنسيق التاريخ ChnageDateFormat() --------------------------------- فى حالة اردتم تغيير التنسيق الى تنسيق أخر مثلا yyyy/MM/dd ChnageDateFormat("yyyy/MM/dd") ملاحظة الحرف M الدال على تسيق الشهر لابد ان يكون Capital Letter اى يكتب كبير M وليس صغير مثل m

حقيقة آثار فضولي ان اري مرفق اخي وأستاذي @ابو جودي بعد ان اطلعت علي الكود بمشاركته الأولي ومن باب الفضول ايضا قمت بوضع رقمي القومي لأنظر هل سيصل الكود الي الصعيد ام لا ولا ادري لماذا اتجهت عيني مباشرة الي العمر ولن ما ادهشني ان عمري قد اصبح 12 عاما فقط حقيقة قد شككت في حساباتي انا ولم اشك بكود استاذنا ابو جودي - واخذت ادعو له بظهر الغيب ان نبهني ان العمر لم يمضي وشمرت عن ساعد الجد لادرك ماظننت انه قد فات في عمر الشباب - ولات حين ادراك 😔 - ولكن قد قمت بالعبث بكود استاذنا وقام بحساب العمر صحيحا علي ما اعتقد وعدلت بعزل نوع الخطأ بعمود مستقل حسب ما فهمت من كلام الاستاذ محمد صاحب الموضوع وهذا المرفق بعد كل هذه الثرثرة قاعدة بيانات موظفين - (3).accdb ملاحظة قمت بحذف بياناتي الشخصية حتي لا يطلع احد علي العمر الحقيقي

شکرا لاستاذ صالح حمادي ذاك الطريقة يتم استخدامه اذا لم يكن الجدول المفروض يغير قيمة الافتراضية كمصدر النموذج اللي نعمل عليه وهذه طريقة يتم استخدامه في نموذج نفسه لجلسة واحدة فقط اي عند اغلاق النموذج راح يرجع لقيمته اافتراضي الاولى ' اذا كان حقل من نوع النصية ستستخدم هذا مثلا Me.Field1.DefaultValue = """" & Me.Field1.Value & """" ' اما اذا كان حقل من نوع الرقمي ستستخدم هذا 'Me.Field2.DefaultValue = "" & Me.Field2.Value & ""

جرب هذا هو من اعمال أسناذنا الكبير محمد الدسوقى له منا كل الحب والإحترام فورم بحث.xlsm

تفضل أخى فورم بحث.xlsm

Option Explicit Sub Test() 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير 'تم هذا الكود في 6/5/2017 'متغيرات Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long 'سطر لمسح النطاق Range("A4:Z1000").ClearContents lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'اسم شيت المصدر والمدى منه arr = Sheets("Sheet1").Range("A7:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 7) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(1, 3, 5) 'اسم شيت الهدف ورقم صف صفحة الهدف Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) 'سطر لمسح التسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0 'سطر للتسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1 j = j + 1 Next i End Sub كود استدعاء بيانات اعمده متفرقه لاعمده اخرى متفرقه في اخر تحسيناته

تفضل جميع التحديثات عبر دالة واحدة فقط UpdateBoxes تشيك بوكس.zip