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

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

السلام عليكم اضع بين ايديكم هذه المعلومة حيث اخذت الفكرة من احد الاحبة في هذا المنتدى وطورتها بحيث لا تستطيع الحذف بعد ادخال البيانات والكبس على ايقونة حفظ ولكي تستطيع الحذف عملت نموذج اخر لا تستطيع الوصول اليه الا برقم سري الرقم السري 12345 جربوا الطريقة عساها تعجبكم العلم لا يحتكر delete_officna.accdb

جرب المثال المرفق ربما يساعدك Database79.accdb

كل الشكر لك استاذي العزيز سليم حاصبيا رغم اني تغلبت على المشكلة وحليتها ولكن ليس بنفس طريقتك فطريقتك سهلة للغاية مقارنة بالطريقة التي حللت بها المشكلة مرفق ملف الحل كما طلب أخي القدير الاستاذ مهند محسن List of Services.xlsx

ممكن ان يكون الحل هنا ايضاً three_cond_format.xlsx

العفو اخى حربى وبلاش استاذى فلست سوى طالب علم شوف التعديل ده واخبرنا بالنتيجه بالتوفيق اخى SuperMarketSals11(1).rar

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

وعليكم السلام اخى الفاضل قم بعمل استعلام لهذا الجدول وفى حقل التاريخ واكتب فى حقل المعيار تحته date() سيتم تصفيه الاستعلام على مدخلات تاريخ اليوم فقط بالتوفيق

وعليكم السلام هل هذا ما تريد شوف واخبرنا تقبل تحياتى SuperMarketSals11.rar

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

السلام عليكم اولا : اهلا فيك في اوفيسنا ثانيا: عمل قاعدة البيانات يتطلب منك بالاول انشاء الجداول لكي يتم بناء قاعدة البيانات عليها. ثالثا" بالنسبة لرقم الجوال يمكن تققيده من خلال قناع الادخال (00000000000) او من خلال كود يضع بعد التحديث او من خلال قاعدة التحقق من الصحة. ملاحظة : بعض الحقول مثل (المؤهل العلمي والتخصص) من الافضل والاجمل ان تكون قائمة منسدلة . - عملت لك جدول عدد /2 بالمرفق قم بالتعديل عليها حسب منتطلبات عملك تحياتي test-1.rar

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

فورم اظهار الادخال الجديد للاسم على الليست بوكس بمجرد الحفظ الفيديو

اخى الفاضل سعر البيع سوف يظهر بعد ما تختار الحجم لان السعر مرتبط ببيان الصنف والحجم ولا انا فاهم غلط جرب مره اخرى ووافنا بالنتيجه بالتوفيق

العفو اخى يوسف بلاش استاذ فلا تناسبنى فلست سوى طالب علم انظر لهذا التعديل لعله يناسبك مبدئيا الى انا يشاركنا احد اخواننا واساتذتنا الافاضل حاولت اعملك الرصيد التراكمى لكن موصلتش تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق موازنة 2020(3).accdb

اخى واستاذى خالد لم الاعتذار فنحن اللذين نثقل عليكم ونتعلم منكم فنحن نطلب مشاركتكم معنا لنتعلم ونستفيد وتصححوا لنا اخطائنا ونتعلمتقبل تحياتى واحترامى 🥀واجمل باقات الوورد لمعلمينا للاسف ملقتيش غير الورده دى فى المحل 😀

باذن الله تعالى

اخي واستاذي حسين اشكرك على مجاملتك الرقيقة ومشاعرك الطيبة

المشكلة في حقل الترقيم التلقائي .

Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = acTextBox or ctl.ControlType = acComboBox Then If ctl.Value <> "" Then ctl = "" End If End If Next ctl عن أذن أخي وحبيبي أحمد غير كلمة and إلى or كما في المثال أعلاه

وعليكم السلام-تفضل لك ما طلبت Classeur4.xlsx

تمت معالجة الامر Option Explicit Sub MY_Data_New() Application.ScreenUpdating = False Dim SH_from As Worksheet Dim T As Worksheet Dim rg_to_Patse As Range Dim Rt%, MY_max%, ro%: ro = 4 Set T = Sheets("Total") Set rg_to_Patse = T.Range("A3").CurrentRegion Rt = rg_to_Patse.Rows.Count If Rt > 1 Then Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1) Else Set rg_to_Patse = T.Range("B4").Resize(, 5) End If rg_to_Patse.Clear For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) SH_from.Cells(3, 1).Resize(MY_max, 6).Copy With T.Cells(ro, 1) .PasteSpecial (xlPasteValues) .PasteSpecial (xlPasteFormats) End With ro = ro + MY_max End If Next SH_from With T.Range("A3").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 End With Application.ScreenUpdating = True arraNge_all End Sub '+++++++++++++++++++++++++++++++++++ Sub arraNge_all() Application.ScreenUpdating = False Dim nro% Dim MM% nro = Cells(Rows.Count, 1).End(3).Row Dim color_rg As Range For MM = 4 To nro If Range("B" & MM).Interior.ColorIndex = 2 Or _ Range("B" & MM).Interior.ColorIndex = -4142 Then GoTo Next_MM If color_rg Is Nothing Then Set color_rg = Range("B" & MM).Resize(, 5) Else Set color_rg = Union(color_rg, Range("B" & MM).Resize(, 5)) End If Next_MM: Next If color_rg Is Nothing Then GoTo Contenu color_rg.Copy Range("B" & nro + 1) color_rg.EntireRow.Delete Contenu: Range("B4", Range("B3").End(4)).Offset(, -1).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" With Range("A3").CurrentRegion .Value = .Value .Borders.LineStyle = 1 End With Range("A4").Select Set color_rg = Nothing create_borders Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub create_borders() Dim My_sh As Worksheet, r For Each My_sh In Sheets If My_sh.Name <> "Total" Then r = My_sh.Cells(Rows.Count, 2).End(3).Row My_sh.Cells.Borders.LineStyle = xlNone My_sh.Range("a2").Resize(r - 1, 6).Borders.LineStyle = 1 End If Next End Sub الملف الأخير Laste_flie.xlsm

الف الف شكر استاذي الفاضل جزاك الله خيرا وجعله الله في ميزان حسناتك وذادك الله من علمه

الف شكر لمعاليك جزاك الله خير

دائما مبدع و متألق اخي خالد اسأل الله لك التوفيق و منكم ما زلنا نتعلم الكثير شكرا لك

مشكور اخي خالد نجح الكود ويعمل بشكل جيد

استاذي ومعلمى الفاضل / @kha9009lid انا متابع معكم كى استفيد جميل جدا هذا الحل استاذى الله يكرمك ويزيدك علما

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

تم تحرير كود لهذا الغرض Option Explicit Sub MY_Data_New() Application.ScreenUpdating = False Dim SH_from As Worksheet Dim T As Worksheet Dim rg_to_Patse As Range Dim Rt%, MY_max%, ro%: ro = 4 Set T = Sheets("Total") Set rg_to_Patse = T.Range("A3").CurrentRegion Rt = rg_to_Patse.Rows.Count If Rt > 1 Then Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1) Else Set rg_to_Patse = T.Range("B4").Resize(, 5) End If rg_to_Patse.Clear For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) SH_from.Cells(3, 1).Resize(MY_max, 6).Copy With T.Cells(ro, 1) .PasteSpecial (xlPasteValues) .PasteSpecial (xlPasteFormats) End With ro = ro + MY_max End If Next SH_from With T.Range("A4").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 .Value = .Value End With Application.ScreenUpdating = True arraNge_all End Sub '+++++++++++++++++++++++++++++++++++ Sub arraNge_all() Application.ScreenUpdating = False Dim nro% Dim MM% nro = Cells(Rows.Count, 1).End(3).Row Dim color_rg As Range For MM = 4 To nro If Range("a" & MM).Interior.ColorIndex <> xlNo Then If color_rg Is Nothing Then Set color_rg = Range("a" & MM).Resize(, 6) Else Set color_rg = Union(color_rg, Range("a" & MM).Resize(, 6)) End If End If Next color_rg.Copy Range("a" & nro + 1) color_rg.EntireRow.Delete Range("A4", Range("A3").End(4)).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" Range("A3").CurrentRegion.Value = _ Range("A3").CurrentRegion.Value Range("A4").Select Set color_rg = Nothing Application.ScreenUpdating = True End Sub الملف من جديد M_data_new_SA.xlsm

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

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

السلام عليكم بدل الطريقة إلى ما في المرفق: DATA_3_ASTLAM.accdb

ستصبح معادلة DCOUNT بهذه الصورة، ولكن الاستعلام سيصبح بطيئاً. DCount("*";"Linking_Tables";"[Bill_ietem]!ITEM_BARCODE='" & [Quantity]![ITEM_BARCODE] & "'" & " and [Bill_ietem]![id_sand] = " & [Quantity]![id_sand])

وعليكم السلام جرب كالتالى ان شاء الله يظبط معك واخبرنا بالنتيجه "[op_date]=# " & forms!sale_center_search!op_date_search & "#" بالتوفيق ان شاء الله

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

أ.يوسف السيد مش فاهم قوى بس قلت أشارك وخلاص .. هذا بالنسبة للسؤال الأول ( ستجد إستعلام جديد إسمه Budget_2 جايز يكون المطلوب ) .. أما الثانى فلو تضيف شاشة الإدخال يكون أفضل. موازنة 2020.accdb

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

الحلقة الرابعة: التعامل مع القائمة المنسدلة في صفحة ويب سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من التحكم الكامل في القائمة المنسدلة داخل الأداة في صفحة ويب لقد قمت بتطبيق هذا الدرس على موقع الفايس بوك لأن به قائمة منسدلة الخاصة بالأشهر و لها خاصية: Id=month لهذه القائمة عمودين عمود مخفي و هو يمثل القيمة الحقيقة به أرقام من 0 إلى 12 و عمود ظاهر به أسماء الأشهر 1- كود حساب عدد عناصر القائمة: MsgBox Me.WebBrowser3.Document.getElementById("month").Length 2- كود معرفة القيمة الحقيقية للعنصر: من المعلوم أن القائمة المنسدلة يمكن أن يكون بها أكثر من عمود يعني ممكن تصبح القيمة الظاهرة تختلف عن القيمة الحقيقية MsgBox Me.WebBrowser3.Document.getElementById("month").Value 3- كود استخراج ترتيب القيمة الظاهرة: استخراج ترتيب القيمة الظاهر ضمن عناصر القائمة المنسدلة MsgBox Me.WebBrowser3.Document.getElementById("month").selectedIndex 4- كود استخراج القيمة الظاهرة: MsgBox Me.WebBrowser3.Document.getElementById("month").Item(Me.WebBrowser3.Document.getElementById("month").selectedIndex).innerText 5- إظهار جميع عناصر القائمة: Dim x As String Dim i As Integer For i = 1 To Me.WebBrowser3.Document.getElementById("month").Length x = x & " - " & Me.WebBrowser3.Document.getElementById("month").Item(i - 1).innerText Next i MsgBox x 6- اختيار عنصر من القائمة باستخدام رقمه الترتيبي: هنا وضعت القيمة تساوي 5 معناه سوف يتم اختيار العنصر رقم 5 و هو مايو Me.WebBrowser3.Document.getElementById("month").selectedIndex = 5 7- تغيير نص قيمة في العمود الظاهر من القائمة: سوف يتم تغيير كتابة أفريل في القائمة إلى أوفيسنا Me.WebBrowser3.Document.getElementById("month").Item(4).innerText = "أوفيسنا" 8-تغيير قيمة في العمود المخفي من القائمة: Me.WebBrowser3.Document.getElementById("month").Item(4).Value = "15" قبل البداية في تطبيق درس اليوم اضغط على زر فتح صفحة الفايس بوك لتظهر الصفحة أمامك webbroser.rar

في المرفقات مثال بسيط بناء على طلبكم يقبل البحث بهمزة وبدون والالف المقصورة مع اليا والتاء المربوطة مع الهاء Database78.accdb

السادة الكرام بداية اشكر كل من ساهم في تطوير وزياده المعرفة لدينا بالاكسل بهذا الجروب العظيم ولذا فقد كان لدي مشكلة ووجدت حلها بحمد الله ولكن في احد المنتديات الاجنبية واحببت ان انقلها هنا للاستفادة الا وهي : كان لدي ملف يحتوي على عدد 200 موظف وكان كل اسم مربوط بارتباط تشعبي عند الضغط عليه تظهر صورة الموظف ولكن الادارة قامت بطلب ان تظهر جميع الصور بجانب الاسم دون الحاجة للضغط على ارتباط تشعبي وهو ما كان في البداية من الصعوبة ان اقوم بعمل ادراج لكل صورة والبحث عن كل اسم . ووجدت هذا الكود والذي يتم استخدامه بواسطة لغة VBA والطريقة كالتالى :- نقوم بالضغط على alt + f11 فيقوم بفتح شاشة VBA من قائمة insert نختار module فيقوم بفتح شاشة لكتابة الكود نقوم باخد الكود التالى نسخ ولصق بها '****************************** '* ConvertHLinksToCellPics * '* Programmer: Ron Coderre * '* Last Update: 06-Apr-2009 * '****************************** Sub ConvertHLinksToCellPics() Dim cCell As Range Dim rngSelection As Range Dim strHLink As String Dim cComment As Comment Dim strPicFileName As String Dim iNewHgt As Integer Dim iNewWidth As Integer For Each cCell In Selection If cCell.Hyperlinks.Count > 0 Then 'The cell contains a hyperlink With cCell 'Store the hyperlink target strHLink = .Hyperlinks(1).Address If strHLink <> "" Then 'Build a picture shape If InStrRev(strHLink, "/") > 0 Then strPicFileName = Mid(strHLink, InStrRev(strHLink, "/") + 1) Else strPicFileName = Mid(strHLink, InStrRev(strHLink, "\") + 1) End If strPicFileName = "pic_" & cCell.Row & cCell.Column InsertPicFromFile _ strFileLoc:=strHLink, _ rDestCells:=cCell, _ blnFitInDestHeight:=True, _ strPicName:=strPicFileName With ActiveSheet.Shapes(strPicFileName) .LockAspectRatio = msoFalse .Height = cCell.Height .Width = cCell.Width End With cCell.Hyperlinks.Delete End If End With End If Next cCell End Sub '****************************** '* InserPicFromFile * '* Programmer: Ron Coderre * '* Last Update: 20-SEP-2007 * '****************************** Sub InsertPicFromFile( _ strFileLoc As String, _ rDestCells As Range, _ blnFitInDestHeight As Boolean, _ strPicName As String) Dim oNewPic As Shape Dim shtWS As Worksheet Set shtWS = rDestCells.Parent On Error Resume Next 'Delete the named picture (if it already exists) shtWS.Shapes(strPicName).Delete On Error Resume Next With rDestCells 'Create the new picture '(arbitrarily sized as a square that is the height of the rDestCells) Set oNewPic = shtWS.Shapes.AddPicture( _ Filename:=strFileLoc, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Left:=.Left + 1, Top:=.Top + 1, Width:=.Height - 1, Height:=.Height - 1) 'Maintain original aspect ratio and set to full size oNewPic.LockAspectRatio = msoTrue oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue If blnFitInDestHeight = True Then 'Resize the picture to fit in the destination cells oNewPic.Height = .Height - 1 End If 'Assign the desired name to the picture oNewPic.Name = strPicName End With 'rCellDest End Sub ومن ثم نقوم بالضغط على f5 لتفعيل الكود ومن ثم اغلاق الشاشة سنلاحظ انه تم اظهار جميع الصور بجانب اسماء العاملين دون الحاجة لادراجها منفرده . ولضبط حجم جميع الصور اختار اي صورة ومن ثم اضغط ctrl + a ستجد تم تحديد جميع الصور ومن ثم كليك يمين - خصائص الصورة وتعديل الطول والعرض فسيتم ظبطها لجميع الصور وفي حالة الرغبة بربط الصورة بالخلية ايضا اضغط على الصور كليك يمين ومن ثم خصائص الصورة ومن ثم خصائص وقم بتحديد خيار ربط الصورة بالخلية اتمنى اكون افدتكم والله الموفق .

جرب هذا الماكرو Option Explicit Sub Get_dif() Dim M As Worksheet, NT As Worksheet, NZ As Worksheet Dim LM As Single, LN As Single, i As Single Dim Dic_M As Object, Dic_N As Object Set M = Sheets("المالية") Set NZ = Sheets("النظام") Set NT = Sheets("النتائج") Set Dic_M = CreateObject("Scripting.Dictionary") Set Dic_N = CreateObject("Scripting.Dictionary") NT.Range("a1").CurrentRegion.ClearContents LM = M.Cells(Rows.Count, 1).End(3).Row LN = NZ.Cells(Rows.Count, 1).End(3).Row For i = 1 To LM If M.Range("A" & i) <> "" Then Dic_M(M.Range("A" & i).Value) = "" End If Next For i = 1 To LN If IsError(Application.Match(NZ.Range("A" & i), Dic_M.keys, 0)) Then Dic_N(NZ.Range("A" & i).Value) = "" End If Next NT.Range("A1").Resize(Dic_N.Count) = _ Application.Transpose(Dic_N.keys) Set Dic_M = Nothing: Set Dic_N = Nothing End Sub الملف مرفق Jard_Mali.xlsm

جرب الملف المرفق بعد إضافة دالة IF على المعادلة.... الغياب دالة البحث.xlsm

يا خرابي ، علاقتنا وصلت لهذه الدرجة 😱🥵😭 العفو ، انا امزح معاك ، واعرف انها خطأ مطبعي 🙂 السبب انك تستخدم ملف MDW هو للتحكم بالمستخدمين ، وابعاد المتطفلين (الغير محترفين 🙂 ). اعمل التالي لوسمحت ، على زر ، في اي برنامج عندك ، اكتب : msgbox currentuser والنتيجة ستكون Admin . هذا معناه ، ان اذا البرنامج غير محمي بملفه الخاص MDW ، فالاكسس سيقرأ اسم المستخدم من الملف الاصل System.MDW . لهذا السبب ، اذا المتطفل اخذ البرنامج ، وحاول يفتحه في على كمبيوتره (بدون وجود ملف MDW ولا المختصر الذي يقرا من MDW ، واستطاع ان يفك ارتباطه من الـ MDW) ، فتلقائيا يجب ان لا يشتغل البرنامج ، وذلك بإتباع : . لهذا السبب ، ولأنه ببساطه للذي يفهم شوي في الاكسس ، يقدر يتخطى هذا الملف ، وللعلم فالحماية هذه عن طريق MDW يعتبرها المحترفين "مجرد قفل صغير" وليس قفلا حقيقيا يحمي البرنامج ، ولهذا السبب ازالته المايكروسوفت من اصدارات 2007 فما فوق (على حد تعبيرهم) 🙂 جعفر

من خلال محرر الاكواد يتم طبع السطر الاتى DoCmd.RunCommand acCmdWorkgroupAdministrator تم استدعاءه المستخدمين من واقع الملف الناتج الذى يحمل امتداد MDW من خلال الدخول الى محرر الاكودا فى الجزء Immediate كما فى الصورة بعد الضغط من لوحة المفاتيخ على زر الادخال Enter يتم فتح مربع حوارى ومن خلال اختيار الاستعراض يتم تحديد مكان الملف دى الطريق الصعبة الطريقة التى افضلها شورت كت للقاعدة ووضع هذا السطر فى الــ Target "C:\Program Files (x86)\Microsoft Office\root\Office16\MSACCESS.EXE" "D:\xxx\zz.mdb" /WRKGRP "C:\Secur\اسم الملف.mdw" مع مراعاة التأكد من المسار لكل من نسخة الاوفيس لملف الاكسيس مساار قاعدة البيانات مسار ملف mdw شوف خذ نسخة من قاعدة لديك وقم بتغيير اللحقة فيها من Accdb الى mdb وقم بعمل كل الخطوات وانظر لترى النتيجه هههههههههههه ممكن نضحك على الاكسس يا سيدى علشان خاطر عيونك يا سلام

السلام عليكم تفضل اخى برنامج لحساب ضريبة القيمة المضافة اقرار-رقم-10-ضريبة-القيمة-المضافة.rar

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

استخدم هذا DCount("OrderID", "tblorders", "[OrderDate] =#" & Format(Me.OrderDate.Value, "mm/dd/yyyy") & "#")

بسم الله الرحمن الرحيم الحمد لله رب العالمين والصلاة والسلام علي سيدنا محمد النبي الامين وعلي من سار بهديه الي يوم الدين اما.....بعد في موضوع لي سابق طرحت كود تفقيط لتحويل الأرقام من أرقام إلى كتابة لكن (إنجليزي) http://www.officena.net/ib/index.php?showtopic=45828&hl= اليوم سأطرح لكم كود تفقيط أو ملف جاهز لإضافته في الفيجول بيسك بكل سهوله وإستخدامه كداله كاي داله أساسيه في الإكسيل طريقة إضافة ملف التفقيط : حمل ملف التفقيط من المرفقات وافتح ملف الإكسيل وإظغط على Alt+F11 وبعدها ستفتح لك صفحة الفيجول بيسك إذهب إلى File وبعدها Import File وضع الملف وأغلق الفيجول بيسك في الإكسيل إذهب الداله المعرفة من قبل المستخدم وستجدها NoToTxt وتابع الإدخالات كما في الصور المرفقة المميز في هذا التفقيط , يمكنك إضافة أي عمله مثل ريال"هلله_جنيه"قرش_دينار"فلس ملف تفقيط + إكسل شيت.rar

السلام عليكم 1. من المعروف ان تنسيق النص في مربع القائمة ListBox هو من اليسار الى اليمين ، مشكلة كانت تصادفني دائما ، وهو تنسيق القيم في مربع القائمة لتكون من اليمين الى اليسار بالنسبة للغة العربية (طريقة تغيير مربع القائمة الى مربع تحرير ونص ، ثم عمل التنسيق عليه من اليمين الى اليسار ، ثم اعادته الى مربع قائمة لا يعمل معظم الوقت) ، موقع http://www.lebans.com والذي يحتوي على مالذ وطاب عنده طريقه لهذا التنسيق: http://www.lebans.com/justicombo.htm كذلك. 2. ونفس المشكلة مع موضوع تنسيق الشجرة TreeView من اليمين الى اليسار. النتيجة: و وطريقة العمل ، يوضع هذا الكود في وحدة نمطية: Option Compare Database Option Explicit #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr Public Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr Public Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr Dim hwnd As LongPtr #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Public Declare Function GetFocus Lib "user32" () As Long Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long Dim hwnd As Long #End If Public Const GW_CHILD = 5 Public Const WS_EX_LAYOUTRTL = &H400000 Public Const GWL_EXSTYLE = (-20) Function RTL_Set(frm As Form, ctl As Control) Dim varHwnd As Variant Dim OldLong As Long frm.SetFocus ctl.SetFocus varHwnd = GetFocus() OldLong = GetWindowLong(varHwnd, GWL_EXSTYLE) SetWindowLong varHwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False End Function Function RTL_SetTree(frm As Form, ctl As Control) Dim OldLong As Long OldLong = GetWindowLong(ctl.hwnd, GWL_EXSTYLE) SetWindowLong ctl.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False End Function ' ' From http://www.microsoft.com/middleeast/msdn/faq.aspx ' 'Place OnLoad of the Form ' Dim OldLong As Long 'For Form ' OldLong = GetWindowLong(Me.hwnd, GWL_EXSTYLE) ' SetWindowLong Me.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For List ' OldLong = GetWindowLong(List1.hwnd, GWL_EXSTYLE) ' SetWindowLong List1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For The StatusBar ' OldLong = GetWindowLong(StatusBar1.hwnd, GWL_EXSTYLE) ' SetWindowLong StatusBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For TreeView ' Dim nodX As Node ' Set nodX = TreeView1.Nodes.Add(, , "R", "Root") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4") ' nodX.EnsureVisible ' OldLong = GetWindowLong(TreeView1.hwnd, GWL_EXSTYLE) ' SetWindowLong TreeView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ListView ' OldLong = GetWindowLong(ListView1.hwnd, GWL_EXSTYLE) ' SetWindowLong ListView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ProgressBar ' ProgressBar1.Value = 50 ' OldLong = GetWindowLong(ProgressBar1.hwnd, GWL_EXSTYLE) ' SetWindowLong ProgressBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ToolBar ' mhwnd = GetWindow(Toolbar1.hwnd, GW_CHILD) ' OldLong = GetWindowLong(mhwnd, GWL_EXSTYLE) ' SetWindowLong mhwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False في اسفل الكود انا تركت الكود لبقية الاشياء اللي يمكن عملها من اليمين الى اليسار. اما تنفيذ التنسيق لمربع القائمة ، فهو وضع هذا الكود عند تحميل النموذج الذي يحتوي على هذا المربع (وهنا اسم حقل مربع القائمة هو List0_RTL ) : 'ListBox RTL Call RTL_Set(Me, List0_RTL) وتنسيق الشجرة ، فهو وضع هذا الكود عند تحميل النموذج الذي يحتوي على الشجرة (وهنا اسم الشجرة هو TreeView1) : 'TreeView RTL Call RTL_SetTree(Me, TreeView1) وللأمانة العلمية ، فاني استخدم قاعدة البيانات التي وضعها الاخ محمد في الرابط: http://www.officena.net/ib/index.php?showtopic=60781 جعفر تعديل 1: 18-11-2021 ، جعل البرنامج يعمل على النواتين 32بت و 64 بت 54.RTL_TreeView_ListBox_32bits_n_64bits.accdb.zip

السلام عليكم جرب الكود التالي Sub kh_split() Dim sp Dim m As String Dim i As Integer m = Range("d5").Formula m = Replace(m, "=", "") sp = split(m, "+") i = UBound(sp) + 1 If i Then Range("G5").Resize(1, i).Value = sp End If End Sub تحياتي