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

السلام عليكم😊 واهنئك أخي المهندس @Eng.Qassim على هذه الترقية، واهلا وسهلا بك معنا من جديد😊 جعفر

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

اختيار موفق استاذ جعفر مع تمنياتي له بالتوفيق

اسف اخي على التاخير ودالك بسبب ظروف العمل تفضل اخي لاكن ركز معي جيدا الفكرة انه تم تصميم نمودج للفاتورة في شيت مخفي يتم نسخ البيانات من الفاتورة اليه ثم اعادة نسخه الى شيت المطبوعات لاجراء اللمسات الاخيرة . يعني عند الرغبة في تعديل شكل الفاتورة لابد من التعديل على الاصل وهو شيت مخفي باسم .(invoice) تم انشاء كودين الاول لطباعة الفاتورة الحالية او استدعاء فاتورة قديمة مثلا وطباعتها ودالك بانشاء شيت جديد باسم فاتورة جاهز للطباعة . يتم حدفه تلقائيا عند اعادة تشغيل الملف مرة اخرى او الرغبة في نسخ فاتورة اخرى يتم حدفه وتعويضه بالفاتورة الجديدة اما بالنسبة لطلبك الاخير فقد تم تعديل كود الترحيل حيث يتم ترحيل البيانات الى شيت اليومية مع نسخ الفواتير تلقائيا في شيت المطبوعات تحت بعض بدون فراغات . وبنفس الفكرة اسف على الاطالة لاكن للتوضيح فقط . اليك الاكواد Sub invoice_printer2() 'هدا الكود لانشاء ورقة جديدة ونسخ الفاتورة Dim ws As Worksheet Dim r As Range Dim MH As Long, MH1 As Long Dim rng As Range Dim i As Integer, counter As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Sheet In ActiveWorkbook.Worksheets If Sheet.Name = "الفاتورة" Then Sheet.delete End If Next Sheet Worksheets("invoice").Visible = True Worksheets("invoice").Copy after:=Worksheets("invoice") ActiveSheet.Name = "الفاتورة" With ActiveSheet MH1 = .Cells(.Rows.Count, "E").End(xlUp).Row - 1 End With Range("b7:E" & MH1).ClearContents Range("c1:c5").ClearContents Set ws = Sheets("الفاتورة") Sheet1.Activate MH = Range("C" & Rows.Count).End(3).Row Range("F9:F" & MH).Copy ws.Range("B7") Range("C9:C" & MH).Copy ws.Range("C7") Range("D9:D" & MH).Copy ws.Range("D7") Range("G9:G" & MH).Copy ws.Range("E7") ws.Range("C2").Value = Range("B3").Value ws.Range("C4").Value = Range("B5").Value ws.Range("C5").Value = Range("B6").Value ws.Range("C1").Value = Range("D6").Value ws.Range("c3").Value = Range("F5").Value Set rng = ws.Range("E7:E30") i = 1 For counter = 1 To rng.Rows.Count If rng.Cells(i) = "" Then rng.Cells(i).EntireRow.delete Else i = i + 1 End If Next Worksheets("invoice").Visible = False Application.ScreenUpdating = True Application.DisplayAlerts = True Sheets("الفاتورة").Activate الكود الثاني والمهم Sub invoice_printer() 'ترحيل الفواتير لشيت المطبوعات تلقائيا عند كل ترحيل Dim ws As Worksheet Dim r As Range Dim MH As Long, MH1 As Long Dim rng As Range Dim i As Integer, counter As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False Worksheets("invoice").Visible = True Set ws = Sheets("invoice") Sheet1.Activate MH = Range("C" & Rows.Count).End(3).Row Range("F9:F" & MH).Copy ws.Range("B7") Range("C9:C" & MH).Copy ws.Range("C7") Range("D9:D" & MH).Copy ws.Range("D7") Range("G9:G" & MH).Copy ws.Range("E7") ws.Range("C2").Value = Range("B3").Value ws.Range("C4").Value = Range("B5").Value ws.Range("C5").Value = Range("B6").Value ws.Range("C1").Value = Range("D6").Value ws.Range("c3").Value = Range("F5").Value derlig = Sheets("الفواتير المطبوعة").Range("a" & Rows.Count).End(xlUp).Row + 1 Worksheets("invoice").Range("A1:E30").Copy Worksheets("الفواتير المطبوعة").Range("a" & derlig) Sheet8.Activate MH2 = ActiveSheet.Range("C" & Rows.Count).End(3).Row For Each c In Range("A1:A5") If c = "" Then c.EntireRow.delete Next Set rng = Sheets("الفواتير المطبوعة").Range("c7:c" & MH2) i = 1 For counter = 1 To rng.Rows.Count If rng.Cells(i) = "" Then rng.Cells(i).EntireRow.delete Else i = i + 1 End If Next Sheet7.Activate With ActiveSheet MH1 = .Cells(.Rows.Count, "E").End(xlUp).Row - 1 End With Range("b7:E" & MH1).ClearContents Range("c1:c5").ClearContents Worksheets("invoice").Visible = False Application.ScreenUpdating = True Application.DisplayAlerts = True Sheets("مستند قيد").Activate End Sub بالتوفيق فاتورة_Mh3 - .xlsm

السلام عليكم 🙂 اخونا @سامي الحداد له صولات في المواضيع ، و ردود موفقة ، فأهلا وسهلا به خبيرا بيننا 🙂 ولايزال البحث مستمر لترقية بقية الاعضاء 🙂 جعفر

السلام عليكم ورحمة الله تعالى وبركاته الاكواد تعتمد على احد دوال ال API للويندوز وتم مراعاة العمل على كلا من النسختين 32 , 64 بيت الكود الاول فى راس الموديول وذلك لاحضار تنسيق تاريخ الجهاز Private Const LOCALE_USER_DEFAULT = &H400 Private Const LOCALE_SSHORTDATE = &H1F ' short date format string Private Const LOCALE_SLONGDATE = &H20 ' long date format string Private Const strTblFormatDate = "tblDateFormatWindows" #If VBA7 And Win64 Then Private Declare PtrSafe Function _ GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" _ (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long #Else Private Declare Function _ GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" _ (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long #End If Public Function GetDateFormatMyWin() Dim strLocale As String Dim lngRet As Long Dim strMsg As String strLocale = Space(255) lngRet = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SSHORTDATE, strLocale, Len(strLocale)) strLocale = Left(strLocale, lngRet - 1) GetDateFormatMyWin = strLocale End Function الكود الثانى التأكد من وجود جدول لحفظ تنسيق تاريخ الجهاز Function ifTableExists(tblName As String) As Boolean If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then ifTableExists = True End Function الكود الثالث جلب البيانات لتسيق تاريخ الجهاز الذى تم حفظه بالجدول Public Function DateFormatwinSaved() As String DateFormatwinSaved = Nz(DLookup("DateFormatWindows", strTblFormatDate), "") End Function الكود الرابع تغيير تسيق التاريح لجهاز الحاسوب ولكن اولا تخزين القيم الاصلية لتنسيق تاريخ الحاسوب داخل جدول لمن يريد استرجاع التسيق الاصلى مرة اخرى Public Function ChnageDateFormat(Optional dtDateFormat As String = "dd/MM/yyyy") If GetDateFormatMyWin() = dtDateFormat Then Exit Function Else Dim mySQL As String If ifTableExists(strTblFormatDate) = False Then DoCmd.SetWarnings False mySQL = "CREATE TABLE " & strTblFormatDate mySQL = mySQL & "([ID] counter," & "[DateFormatWindows] text," & "CONSTRAINT [Index1] PRIMARY KEY ([ID]));" DoCmd.SetWarnings False: DoCmd.RunSQL mySQL: DoCmd.SetWarnings True mySQL = "INSERT INTO " & strTblFormatDate mySQL = mySQL & "( DateFormatWindows )" mySQL = mySQL & " SELECT " mySQL = mySQL & " ('" & GetDateFormatMyWin() & "') " DoCmd.SetWarnings False: DoCmd.RunSQL mySQL: DoCmd.SetWarnings True ElseIf ifTableExists(strTblFormatDate) = True Then If DCount("*", strTblFormatDate) = 0 Then mySQL = "INSERT INTO " & strTblFormatDate mySQL = mySQL & "( DateFormatWindows )" mySQL = mySQL & " SELECT " mySQL = mySQL & " ('" & GetDateFormatMyWin() & "') " DoCmd.SetWarnings False: DoCmd.RunSQL mySQL: DoCmd.SetWarnings True ElseIf DCount("*", strTblFormatDate) > 0 Then mySQL = "UPDATE " & strTblFormatDate mySQL = mySQL & " SET " & strTblFormatDate mySQL = mySQL & ".DateFormatWindows = " & Chr(34) & GetDateFormatMyWin() & Chr(34) & ";" DoCmd.SetWarnings False: DoCmd.RunSQL mySQL: DoCmd.SetWarnings True End If End If Shell "cmd.exe /c REG ADD ""HKEY_CURRENT_USER\Control Panel\International"" /v sShortDate /d """ & dtDateFormat & """ /F", vbHide End If End Function الكود الاخير ارجاع التنسيق مرة اخرى للحاسوب والذى تم الاحتفاظ به داخل الجدول Public Function ReturnOldDateFormatWin() If GetDateFormatMyWin() = DateFormatwinSaved() Then Exit Function Else Shell "cmd.exe /c REG ADD ""HKEY_CURRENT_USER\Control Panel\International"" /v sShortDate /d """ & DateFormatwinSaved & """ /F", vbHide End If End Function طيب فى النهاية يفضل استخدام ماكرو AutoExec والذى وظيفته تنفيذ إجراء او اجراءات معينة في كل مرة تبدأ فيها تشغيل قاعدة بيانات Access وفى الماكرو من خلال RunCode نكتب اسم الوظيفة التى نريد استدعاؤها وهى ChnageDateFormat() الان عند تشغيل القاعدة يتم فحص تنسيق تاريخ الجهاز وان كان مساويا للتنسيق الموجود فى الفانكشن ChnageDateFormat والذى وضعته افتراضيا من خلال Optional dtDateFormat As String = "dd/MM/yyyy" يتم تجاهل الامر وفى حالة الاختلاف يتم تغيير تنسيق تاريخ الجهاز الى هذا النسيق الذى تم الاعلان عنه فى رأس الوظيفة dd/MM/yyyy ولاضفاء المرونة قمت بتعريف متغير التنسيق على انه اختيار ووضعت الاختيار المفضل dd/MM/yyyy فى حالة اردتم تغيير التنسيق الى تنسيق أخر مثلا yyyy/MM/dd كل ما عليكم هو استدعاء الوظيفة فى الماكرو بالشكل الاتى ChnageDateFormat("yyyy/MM/dd") ان شاء الله بهذا الكود لن تواجهوا مستقبلا مشاكل اختلاف تنسيق التاريخ فى دوال المجال ولا اخطاء فى تسجيل التواريخ .. بلا ..بلا ..بلا.................... الخ الخ طيب لو اردتم ارجاع التنسيق الافتراضى الذى كان قبل ذلك والذى احتفظنا به فى الجدول كل ما عليكم هو استدعاء الوظيفة الاتية عند الاغلاق لقاعدة البيانات ReturnOldDateFormatWin() انتهى الشرح ارجوا لكم تجربة الاستمتاع بتلك الافكار وهذه التجربة الافكار والاكواد وطرح التصور حصرى من بنات افكارى وانا مجهد جدا جدا جدا قد يمكن اختصار الاكواد واختزالها ولم انتبه لذلك مثلا من شدة الارهاق فلا تؤاخذونى فى ذلك .. و ليدلوا كل بدلوه فى ذلك الامر ... تم التجربة على ويندوز 10 - 64 بيت ولا ادرى هل يعمل على باقى واختلاف نسخ الويندور ام لا انتظر الرد من حضراتكم بنتائج تجاربكم ووضع اقتراحاتكم

تقصد انه عندك جدول يحتوي على اسماء وارقام هواتف وبعض الاسماء لديهم اكثر من تلفون فممكن يكون الرقم مسجل في حقل tel1 وممكن يكون الرقم في حقل tel2 وعندما تضع رقم الهاتف ترغب ان يبحث عنه في الحقلين اذا كان فهمي صحيح للموضوع ممكن عملها مع تبديل مايلزم =DLookUp("[s_name]";"tbl_2";"[tel1]&[tel2] like '*" & [tx2] & "*'") ☝️هذا الاستخدام للدالة بمعيار حقلين في الجدول شرحه استاذنا @أبو إبراهيم الغامدي في هذا الموضوع ⬇️ تحياتي

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

وهو بالفعل خبير زاده الله من فضله الف الف الف مبروك

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

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

مبارك مهندسنا .............. الف ... الف ... مبروك ..... تستاهل ... مزيد من التألق

تفضل اخي تمت اضافة صف بين كل فاتورة فاتورة_Mh4 - .xlsm

السلام عليكم😊 اخوي ابو أحمد كفيت ووفيت، وفي الواقع وبعد عدة من استفسارات اخونا nssj، كنت اعتقد بأنك ستتوقف، ولكنك كنت تبهرني بإجابة وكود أفضل من سالفها، فهذا عهدنا بك، شكرا جزيلا😊 اخوي rockjones33 لك أسلوب غير متعارف عليه في الرد، فما شاء الله عليك مشرّق ومغرّب في نفس اللحظة، لهذا السبب وبسهولة ممكن الواحد يفهمك غلط، وخصوصا ان كلامك وامثلتك غير محددة الاتجاه، وأنا شخصيا ماني ملحق عليك🤔 اعتقد انكم جميعا توجهون كلامكم لصاحب السؤال، واتمنى من اخوي rockjones33 صياغة ردودة بطريقة مفهومه لنا 😊 جعفر

ألف مبروك مع تمنياتي له بالتوفيق

نبارك للمهندس قاسم الترقية ، وعساكم ع القوة

ما هي المشاكل التي تواجهها أخي حمدي ؟

وعليكم السلام ورحمة الله , كان هناك مشكلة في دالة like قمت بتعديلها وايضا قمت بتعديل مصدر بيانات نموذج الموظفين الى استعلام وبحث شامل new one.accdbربط الاستعلام مع التقرير ,, اتمنى ان اكون قد ساعدتك بحل المشكلة

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

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

وعليكم السلام ريما Sub test() Dim a, b, c Dim i&, ii& a = Cells(3, 2).CurrentRegion b = Cells(3, 10).CurrentRegion.Offset(2).Columns(1) ReDim c(1 To UBound(b) - 2) For i = 2 To UBound(a) For ii = 3 To UBound(a, 2) If (a(i, ii)) <> "" Then c(Application.Match(a(i, ii), b, 0)) = a(i, 2) Next Next Cells(5, 11).Resize(UBound(c)) = Application.Transpose(c) End Sub

هذه قائمة بأنواع الحقول الرقمية وخصائص كل نوع

يستاهل المهندس قاسم 👍🏼😊🌹 الله يوفقك مهندسنا العزيز 🌸🌷🌹

السلام عليكم تم الاستغناء عن العمود المساعد... ترتيب معلمين حسب الاقدمية (1).xlsm

الف مبروك 💐 و الي الأمام دائما باذن الله

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

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

سلام عليكم اتمنى ان فهمت المطلوب وانه تم تطبيقة لك ترتيب معلمين حسب الاقدمية.xlsx

وعليكم السلام طمنتني ، شكرا لك أستاذ محمد ، توقعت هكر داخل باسمي بطريقة غير شرعية ، وكنت خائف من العواقب 🙂 . بالتوفيق.

السلام عليكم لاحظت كثرة الأسئلة حول كيفية البحث بتجاهل أنواع الألف (ا أ إ آ) فقررت إنشاء موضوع أشرح فيه هذه الطريقة مع وضع مثال بسيط. مثلا عندما أبحث عن كلمة أحمد يكفي أن أكتب: احمد فتظهر الأسماء المكتوبة بالهمزة و بغير همزة. و غيرها مع باقي الأنواع. الكود المستعمل: Dim rst As String, x As String, CrtTxt As String Dim i As Integer, RC As Integer Dim homm As String homm = Me.t2.Text Me.t3.Value = homm CrtTxt = "Like ""*" & Me.t3 & "*""" If InStr(1, Me.t3, "أ") > 0 Or InStr(1, Me.t3, "ا") > 0 Or InStr(1, Me.t3, "إ") > 0 Or InStr(1, Me.t3, "آ") > 0 Or InStr(1, Me.t3, "ى") > 0 Or InStr(1, Me.t3, "ي") > 0 Or InStr(1, Me.t3, "ه") > 0 Or InStr(1, Me.t3, "ة") > 0 Then CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Me.t3, "ا", "أ") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Me.t3, "ا", "آ") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Me.t3, "ا", "إ") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Me.t3, "ة", "ه") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Me.t3, "ه", "ة") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Me.t3, "ى", "ي") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Me.t3, "ي", "ى") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "أ"), "ي", "ى") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "آ"), "ي", "ى") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "إ"), "ي", "ى") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "أ"), "ى", "ي") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "آ"), "ى", "ي") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "إ"), "ى", "ي") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "أ"), "ة", "ه") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "آ"), "ة", "ه") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "إ"), "ة", "ه") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "أ"), "ه", "ة") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "آ"), "ه", "ة") & "*""" CrtTxt = CrtTxt & " or [الكود] Like ""*" & Replace(Replace(Me.t3, "ا", "إ"), "ه", "ة") & "*""" End If rst = ("SELECT * FROM [جدول1] where [الكود] " & CrtTxt & ";") Me.salah.Form.RecordSource = rst Me.salah.Requery و هذا مثال على ذلك: البحث بتجاهل أنواع الألف.rar وهذا رابط فديو شرحت به البرنامج: