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

وعليكم السلام ورحمة الله تعالى وبركاته استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل .. حياكم الله وبياكم اولا وقبل كل شئ اشتاقت لكم نفسى كثيرا ... اسال الله تعالى لكم الصحة والعافية والبركة فى العمر والعلم والعمل والاهل والولد وكل اساتذتى الكرام واخواننا مشاركة مع اساتذتى الأفاضل هذا تطبيقى المتواضع بناء على توجيهاتكم ولكن بما ان اخى الكريم الاستاذ @alzahrani2014 يريد عمل فزر وتصفية فى نموذج تلك فكرتى المتواضعة وحاولت جاهدا امعان النظر والتفكير خارج الصندوق وفى انتظار رأيكم وتوجيهاتكم المرفق يضم بين طياته - نموذج واحد لإجراء الفرز والتصفية على كل البيانات سواء كان السجل سرى أو غير سرى -عند فتح النموذج يتم الفرز والتصفية فقط على السجلات الغير سرية -عند تحديث مربع السرد الخاص بالفرز فى حالة كانت البيانات سرية يتم اخفائها على الفور وتظهر البيانات فقط بكتابة كلمة المرور الصحيحة (123) والا لا ولن يتم عرض البيانت >>---> حيلة وخدعة -التغلب على التنقل بين الحقول بالضغط على زر TAP من لوحة المفاتيح حتى لا يتم استعراض البيانات السرية >>---> حيلة وخدعة -فى حالة الغاء الفرز والتصفية سواء كان السجل الحالى سرى او حتى بعد ادخال كلمة مرور خطأ او حتى كان السجل الحالى لا يحتوى بيانات سرية يتم اليا اجراء تطبيق الفرز على السجلات الغير سرية - طبعا تم التعديل على بنية الحقل sec فى الجدول بتحويله الى حقل رقمى وتم التعديل علية بحيث يتم تحويله الى Combo Box بحيث يكون نوع مصدر بيانات الحقل Value List وقيم الحقل الافتراضية تتكون من -1;"سرى";0;"غير سرى" -تم اضاقة موديول لاخفاء كلمة المرور اثناء الكتابة لتظهر على شكل ***** اترككم مع المرفق b2- Moh3sam.mdb

حياك الله أبو زهرة ..... بارك الله فيك ... New Microsoft Access Database.rar

* يمكن بعمل حماية للخلايا بكلمة مرور هكذا لا يمكن التعديل اليدوي إلا بكتابة كلمة المرور * وبالنسبة لتعديل الخلايا المحمية بالكود فيجب وضع سطر فك الحماية في بداية الإجراء ActiveSheet.UnProtect password:="mas" ويجب وضع سطر الحماية قبل نهاية الإجراء ActiveSheet.Protect password:="mas" حيث mas هي كلمة المرور المطلوبة بالتوفيق

وعليكم السلام ورحمة الله وبركاته بالاضافة الى ما تفضل به استاذنا الفاضل @ابوخليل وله الشكر جرب الكود التالي Me.Filter = "noo =" & Me.مربع_تحرير_وسرد7 Me.FilterOn = True Me.Requery If Me.sec.Value = "سري" Then Me.Visible = False If InputBox("الرجاء ادخال كلمة السر لفتح النموذج", "فتح النموذج") = "123" Then Me.Visible = True Else Me.Visible = False DoCmd.GoToRecord , , acNewRec End If End If b21.accdb تحياتي

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

Can you give us the exact dates for each zodiac sign as you did for Virgo (which is from 23 Aug to 22 Sept) https://en.wikipedia.org/wiki/Astrological_sign And is that Vrigo starts at 23 Aug and included and ends at 22 Sept and included. I mean if we need to compare a date then we say greater than or equal 23 Aug and less than or equal to 22 Sept Can you review this udf that returns the zodiac for each date Function ZodiacSign(myDate As Date) As String Dim yr As Integer yr = Year(myDate) Select Case myDate Case Is >= CDate("12/22/" & yr), Is <= CDate("1/19/" & yr) ZodiacSign = "Capricorn" Case Is <= CDate("2/18/" & yr) ZodiacSign = "Aquarius" Case Is <= CDate("3/20/" & yr) ZodiacSign = "Pisces" Case Is <= CDate("4/19/" & yr) ZodiacSign = "Aries" Case Is <= CDate("5/20/" & yr) ZodiacSign = "Taurus" Case Is <= CDate("6/21/" & yr) ZodiacSign = "Gemini" Case Is <= CDate("7/22/" & yr) ZodiacSign = "Cancer" Case Is <= CDate("8/22/" & yr) ZodiacSign = "Leo" Case Is <= CDate("9/22/" & yr) ZodiacSign = "Virgo" Case Is <= CDate("10/22/" & yr) ZodiacSign = "Libra" Case Is <= CDate("11/22/" & yr) ZodiacSign = "Scorpio" Case Is <= CDate("12/21/" & yr) ZodiacSign = "Sagittarius" End Select End Function

المتغير k يزيد بمقدار 1 وهو المسئول عن وضع المواد في الأعمدة من 114 وما بعدها لذا ينبغي تعديل هذه السطور Cells(i, k ) = Cells(4, y - 2) k = k + 1 Else Cells(i, k ) = "" إلى Cells(i, k + (y - 10) / 9) = Cells(4, y - 2) Else Cells(i, k + (y - 10) / 9) = "" لأن y بدايتها 10 والخطوات 9 ويوجد في الفصل الثاني نفس الكود ولكن بداية y هي 16 بالتوفيق

@hassansaat تعلم الاستيراد بكل سهولة في البداية قم بإستدعاء مكتبة الإكسل الآن نقوم بإنشاء Module جديد و اضافة الكود التالي Public filenname As String Public Function importExcel(tablename As String) As String ', filenname As String Dim xlApp As Excel.Application Dim xlWb As Excel.Workbook Dim xlWs As Excel.Worksheet Dim intLine As Long Dim strSqlDml As String Dim strColumn1 As String, strColumn2 As String, strColumn3 As String varfile = filenname CurrentDb.Execute "DELETE * FROM List", dbFailOnError Set xlApp = New Excel.Application xlApp.Visible = False Set xlWb = xlApp.Workbooks.Open(varfile) Set xlWs = xlWb.Worksheets(1) intLine = 2 Do strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) strSqlDml = "INSERT INTO List VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')" CurrentDb.Execute strSqlDml, dbFailOnError xlWs.Cells(intLine, 1).Select intLine = intLine + 1 Loop Until IsEmpty(xlWs.Cells(intLine, 1)) xlWb.Close False xlApp.Quit Set xlApp = Nothing Set xlWb = Nothing Set xlWs = Nothing filenname = "" End Function Public Sub SelectFiles() Dim Addfile As Object Set Addfile = Application.FileDialog(3) With Addfile .AllowMultiSelect = False .InitialFileName = "" .Filters.Clear .Filters.Add "Excel Files", "*.xls,*.xlsx" If .Show = True Then filenname = Trim(.SelectedItems(1)) Else Exit Sub End If End With End Sub شرح مختصر للكود نقوم بالإعلان عن متغييرات تحمل اسماء مستعارة للأعمدة في ملف الإكسل مثلا strColumn1 -strColumn2 - strColumn3 Dim strColumn1 As String, strColumn2 As String, strColumn3 As String الأن نقوم بتعريف المتغييرات على الأعمدة في ملف الأكسل من خلال التعريف xlWs.Cells(intLine, 1).Value حيث أن رقم 1 هو العمود رقم 1 في الاكسل و هكذا strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) تفضل التعديل Access-Import.accdb

سلام اخوتي كيف يمكن حماية cells من التعديل اليدوي مع امكانية التعديل الاوتوماتيكالي

في حدث عند النقر المزدوج لـــــ lst4 ضع هذا الكود <<<<<<<>>>>>>> DoCmd.OpenReport "rpt_class", acViewPreview, , "class Like '*" & Me.lst4.Column(1) & "*'"

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

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

احسنت استاذ محمد ..فعلا هذا هو المطلوب ..بارك الله فيك ..ولا يهون الجميع اساتذتي واخوتي

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

شكرا لاهتمامك بالموضوع وبارك الله فيك وزادك الله علما

السلام عليكم تواجه كثيراً من مستخدمي إكسل مشكلة تشفير الكتابة العربية في الملفات وخاصة تلك المصدرة من الأجهزة والبرامج الأخرى كجهاز البصمة أو الملفات المحملة من الإنترنت أقدم لكم هذا الكود الذي كتبته بعد بحث في موضوع اليونيكود خاصة أني سابقاً قد عانيت من المشكلة و الحلول البديلة تسمح بمعرفة المحتوى دون القدرة على تحويل الملف بالكامل. ملاحظة : يفضل نسخ الملف المشفر قبل إجراء التحويل عليه. a Code shows invalid/ decrypted characters in Excel properly والحمد لله الذي بنعمته تتم الصالحات و صلى الله على سيدنا محمد وعلى آله وصحبه أجمعين وسلم تسليماً كثيراً. عند فتح الملف هنا زر بالنقر عليه تفتح نافذة لاختيار الملف المطلوب ثم مربع حوار لكتابة اسم الورقة ثم مربع حوار اختيار المجال المراد تغييره عن طريق التحديد. الفانكشن في البداية يمكن استدعاؤها كدالة من دوال إكسل ضمن ورقة البيانات يكفي لذلك = InStead(YourText or Cell Address) Public Function InStead(T1 As String) ' Created by Khalf Officena Forums 20/02/2020 ' www.officena.net ' Hamdi Edlbi ' This Code for Showing Arabic Characters Properly In Excel Dim w As Integer w = Len(T1) For X = 1 To w T2 = Mid(T1, X, 1) T3 = AscW(T2) T4 = Chr(T3) T5 = T5 & T4 Next X InStead = T5 End Function Sub InSteadAll() ' This Sub For Call the Function In The Current Sheet On Error Resume Next Dim C As Range For Each C In Selection C.Value = InStead(C.Value) Next End Sub Sub ChooseRange() 'Choose the Range Dim rng As Range Set rng = Application.InputBox("Select The Range", "Decryption Characters", , , , , , 8) Application.Goto rng ' Call The Sub InSteadAll Call InSteadAll End Sub Sub OpenWorkbook() 'Apply The Code to Another Workbook On Error Resume Next Dim strFile As String Dim X As String strFile = Application.GetOpenFilename() Workbooks.Open (strFile) ' These Followed Couple of Lines are Optional In Case You Need to Get Specific Sheet X = Application.InputBox("Select The Sheet", "Decryption Characters", , , , , , 2) Sheets(X).Activate Call ChooseRange End Sub Decryption_Invalid_Characters.xls

طريقة تنفيذ هذا الكود

جزاك الله خيرا استانا الفاضل @ابا جودى على هذا العمل الرائع واثراءا للموضوع اسمح لي بتطبيق الفكرة بشكل اخر مختصر بعض الشىء Private Sub XH_S() If Me.sec.Value = "سري" Then Me.Label12.Visible = True Else Me.Label12.Visible = False End If End Sub Private Sub Form_Current() Me.مربع_تحرير_وسرد7.SetFocus XH_S End Sub Private Sub Form_Open(Cancel As Integer) XH_S End Sub Private Sub مربع_تحرير_وسرد7_AfterUpdate() Me.Filter = "noo =" & Me.مربع_تحرير_وسرد7 Me.FilterOn = True Me.Requery If Me.sec.Value = "سري" Then ' Me.Visible = False If InputBox("الرجاء ادخال كلمة السر لفتح النموذج", "فتح النموذج") = "123" Then Me.Label12.Visible = False Else ' Me.Visible = False Me.Label12.Visible = True End If End If End Sub b21.accdb تحياتي

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

بعد اذن استاذنا @kanory تفضل New Microsoft Access Database.rar

كلام @ابوخليل سيف ... حفظكم الله جميعا ... استفدت منكم كثيرا وقرب مشروعي على الانتهاء بفضل الله ثم عونكم

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

السلام عليكم الافضل لك ان تعمل نموذجا خاصا لعرض السجلات السرية ، ويكون الدخول اليه برقم سري وملاحظة صغيرة : حاول ان تكون البيانات في الجدول عبارة عن ارقام سواء كان نوع الحقل رقمي او نصي مثلا : سري وغير سري يكون صفر وواحد يمكنك ترجمة هذه الارقام من خلال النماذج والتقارير عندما تتقدم في البرمجة سيتضح لك فائدة ذلك

وعليكم السلام ورحمة الله وبركاته ضع الكود في وحدة نمطية وغير Private الى Public مؤشر.rar تحياتي

نعم تعمل لكنك لن تحتاج لها لان مافعله الاستاذ @ابوخليل سوف لن يجعل عدد الايام اكثر من 30 او عدد الاشهر اكثر من 12 واليك مافعله استاذنا للاستفادة : 1- في عمود rs تم حساب عدد الايام للخدمة الكلية 2- العمود rsw يظهر لنا باقي قسمة عدد الايام الكلي على 360 يوم والتي نحتاجها لاحقا 3- العمود rs_y يظهر لنا عدد سنوات ايام الخدمة الفعلية دون كسور مع الانتباه الى ان الاستاذ استخدم العلامة (\) وليس علامة القسمة (/) 4- العمود rs_d يظهر لنا المتبقي من قسمة عدد الايام الكلية مقسوما على 30 يوم 5- العمود rs_m يظهر لنا ناتج طرح الايام التي ظهرت في عمود الفقرة 2 امن الايام التي ظهرت في العمود 4 مقسوما على 30 لتظهر لنا عدد الاشهر 6- النتيجة ظهرت لنا عدد السنوات في rs_y وعدد الاشهر في rs_m وعدد الايام في rs_d

جميعا بإذن الله

ينغي فك الدمج في جميع الخلابا المدمجة قبل استعمال الفرز أو الترتيب بعد فك الدمج في الأعمدة وتحديد أول صف قبل البيانات والضغط على زر التصفية filter في تبويب بيانات data (رمز القمع) سيتحقق المطلوب بإذن الله

تفضل جمع مدد الخدمة بالنموذج2.rar

السلام عليكم هل من طريقة لتفعيل خاصية import data من خلال fichier pdf على اكسل 2019 و شكرا هذه الصورة مأخوذة من النت أما عندي فلا توجد هذه الخاصية

ياستاذ محمد شكرا على تفاعلك معى للموضوع بس هذه الجزئية ممكن تحولها الى صيغة افهمها لانه صعبه فى الفهم انظر الى هذه الجملة مثلا (RC10:RC[-1]) ولكن ماتحولها الى رنج عادى هنفهمها

الشكر لله وفقنا الله جميعا لكل خير

يوجد رموز غير مطبوعة نتيجة اختلاف نظام التشغيل في الأجهزة المستخدمة في تصدير هذه البيانات واستيرادها لحذف هذه الرموز نستعمل هذه المعادلة =SUBSTITUTE(SUBSTITUTE(A1,CHAR(13),""),CHAR(10),"") بالتوفيق

مشاركة مع استاذ قاسم تفضل التعديل ارجو ان يكون طلبك برنامج الديون-1.rar

الشكر لله أخي الكريم يبدو أنك ما لاحظت أن المسلسل بعد 1009 هو 1010 وليس 10010 أو ربما يكون التسلسل الصحيح يقفز من 1009 إلى 10010 وحضرتك نسيت وكتبت التسلسل كما بالصورة المأخوذة من ملفك بنيت فكرتي في الحل على مسلسل الرقم والكود وليس على الفكرة الموجودة في الملف وهي دمج الرقم مع 100 نظرا لعدم موافقتها للتسلسل خالص دعواتي بالتوفيق

بعد إذن صديقي العزيز @Ali Mohamed Ali هذه الحيلة لن تفيد مع دمج الرقم 100 مع 10 لأن الناتج سيكون 10010 عشرة آلاف وعشرة وليس 1010 لذا أقترح وضع هذه المعادلة في C1 =SUM(1000,A1) وفي هذه الحالة يمكن الاستغناء عن العمود B مرفق الملف بعد التعديل ليتناسب مع الأرقام بعد 9 بالتوفيق TEST.xlsx

وعليكم السلام-اجعل المعادلة بالعمود C هكذا =VALUE(B1&A1) TEST1.xlsx

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

ههههه .... اذن حاول انقاذ الموقف .... بتعديل كودك .... 😁

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

استبدل الكود الموجود لديك بهذا الكود ..... On Error Resume Next Dim Db As DAO.Database Dim Rc As DAO.Recordset Dim ChequesFound Dim ChequeNoStart As Long Dim ChequeNoEnd As Long Dim i As Long Set Db = CurrentDb Set Rc = Db.OpenRecordset("SELECT SamoBrojevitxt([dbo_ID]) AS Brojevtxti FROM dbo_Tbl_Emp ORDER BY SamoBrojevitxt([dbo_ID]);") Do While Not Rc.EOF Rc.MoveNext Loop If Rc.RecordCount = 0 Then dbo_ID = "Em." & Right(Year(Date), 2) & "001" 'MsgBox "No Records Found" GoTo cmdDisplay_Exit End If DoCmd.GoToRecord , "", acNewRec Rc.MoveFirst ChequesFound = Rc.GetRows(Rc.RecordCount) ChequeNoStart = ChequesFound(0, 0) ChequeNoEnd = ChequesFound(0, UBound(ChequesFound, 2)) For i = ChequeNoStart To ChequeNoEnd If BinarySearch(ChequesFound, i) = False Then dbo_ID = "Em." & i GoTo cmdDisplay_Exit Else dbo_ID = "Em." & Replace(Nz(DMax("dbo_ID", "dbo_Tbl_Emp", "dbo_ID like 'Em." & Right(Year(Date), 2) & "*'"), "Em." & Right(Year(Date), 2) & "000"), "Em.", "") + 1 End If Next i cmdDisplay_Exit: Set Rc = Nothing Set Db = Nothing

Worksheet module Private Sub TextBox1_Change() SumInTextBox End Sub Private Sub TextBox2_Change() SumInTextBox End Sub Private Sub TextBox3_Change() SumInTextBox End Sub Sub SumInTextBox() Dim m1 As Double, m2 As Double, m3 As Double m1 = Val(TextBox1.Value) * Range("G4").Value m2 = Val(TextBox2.Value) * Range("G6").Value m3 = Val(TextBox3.Value) * Range("G9").Value TextBox4.Value = m1 + m2 + m3 End Sub

بعد الانتهاء من اضافة الموظف قم بالضغط على حفظ ....... انظر المرفق ربما هو ما تريد .... dbo_da_kan.accdb

ممكن مرفق صغير للتعديل عليه .... لان الشغلة تحتاج عمل واكواد بارك الله فيك

أحسنت استاذ خلف جزاك الله كل خير

بارك الله فيك مزيدا من العلم والعطاء

جزاك الله كل خير يا خبور خير وكل عام أنتم جميعا بخير تقبل الله منا ومنكم صالح الأعمال

في التأني السلامة الموضوع كبير

الرابط شغال ودائم بإذن الله لأني على حسابي في هذا الموقع وللعلم تم تحميل الملف 1100 مرة من يوم 21/7 حتى الأن 10/8 وجاري تطوير البرنامج وسيت رفعه متى تم بإذن الله

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

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