اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

  1. د.كاف يار

    د.كاف يار

    الخبراء


    • نقاط

      9

    • Posts

      1,681


  2. سليم حاصبيا

    سليم حاصبيا

    أوفيسنا


    • نقاط

      8

    • Posts

      8,723


  3. jjafferr

    jjafferr

    أوفيسنا


    • نقاط

      3

    • Posts

      9,724


  4. محمد أبوعبدالله

    • نقاط

      2

    • Posts

      1,998


Popular Content

Showing content with the highest reputation on 16 سبت, 2020 in مشاركات

  1. جرب هذا الكود( بدون معادلات) Option Explicit Dim My_formula$ Dim Ar(), i% Dim Ar1() Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$4" _ And Target <> "" And Target.Count = 1 Then vl_formula End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++++++++ Sub vl_formula() My_formula = "=IFERROR(VLOOKUP(A4,id!A4:P500,2,0),"""")" Ar = Array(2, 3, 12, 13, 15, 8, 14, _ 6, 5, 4, 7, 10, 9, 11) Ar1 = Array("C5", "G5", "C7", "E7", "G7", _ "C9", "E9", "G9", "C11", "E11", "G11", _ "C13", "E13", "C15") For i = LBound(Ar) To UBound(Ar) Range(Ar1(i)) = Evaluate(Replace(My_formula, 2, Ar(i))) Next End Sub الملف مرفق Zoukra.xlsm
    2 points
  2. تفضل التعديل اخي الكريم Up_عقود.rar
    2 points
  3. السلام عليكم أعتقد أن هناك خطأ في القيمة 0.44 التي وضعتَها والصحيح هو 0.73... ومعذرة على الخطأ الذي اقترفتُه في ملفي السابق عند حساب المتوسط الكلي للعينات و الانحراف المعياري الكلي... بن علية حاجي الإحصاء 22.xlsx
    2 points
  4. وبسطر واحد : DoCmd.GoToControl Screen.PreviousControl.Name جعفر
    1 point
  5. اللي فهمته : عندك الحقل A , وخرجت منه الى الكومبوبوكس ، وبعدين تريد ترجع مرة ثانية من الكومبوبوكس الى الحقل A : هذا الكود يكون في احد احداث الكومبوبوكس : Dim ctrl As Control Set ctrl = Screen.PreviousControl DoCmd.GoToControl ctrl.Name واذا تريده بدلا من DoCmd.CancelEvent If IsNull([Namee]) Then MsgBox "لاتترك الحقل فارغاً **هذا الحقل اجباري ** ادخل الاسم الرباعي", vbCritical + vbMsgBoxRight, "تحذير ..!!" 'DoCmd.CancelEvent Dim ctrl As Control Set ctrl = Screen.PreviousControl DoCmd.GoToControl ctrl.Name End If جعفر
    1 point
  6. السلام عليكم 🙂 لو تتبع هذه الطريقة ، ما تتعب 🙂 جعفر
    1 point
  7. شكرا استاذ ازهر وشكرا يادكتور كاف يعطيكم الف عافيه وفقكم الله لما يحبه ويرضاه
    1 point
  8. تفضل هذا التعديل اخي الكريم ( اكتشفت خطأ في حساب التاريخ حيث تم التعديل ليحسب من التاريخ الحالي للنظام ) Up_عقود_2.rar
    1 point
  9. تفضل هذه مشاركة من طرفي اخي طلال لكي تتعدد امامك الحلول و تختار الانسب منها المشاريع.rar
    1 point
  10. السلام عليكم هو شيت بسيط لا يحتوي الا على معادلتين تم ارفاق الملف مدعوم بشرح واتمني ان يكون الشرح وافي نسخة من خدمة شؤون الموظفين.xlsx
    1 point
  11. غير خاصية LimitToList / الالتزام بالقائمة الى yes تحياتي
    1 point
  12. قبل كل شيء ازالة الحلايا المدمجة من الملف
    1 point
  13. وعليكم السلام توضيحnn.rar
    1 point
  14. الف مبروك ... الاخ العزيز جعفر وانتمنى ان اشوف جميع المشتركين فى الموقع خبراء
    1 point
  15. تفضل اخي الكريم Private Sub city_NotInList(NewData As String, Response As Integer) Dim ctl As Control Dim strSQL As String Set ctl = Me!city If MsgBox(" اسم المدينة" & " / " & _ Me.city.Text & " / ليس ضمن القائمة هل تريد إضافته ", _ vbOKCancel, "officena") = vbOK Then Response = acDataErrAdded strSQL = "INSERT INTO tbl_city(city) VALUES('" strSQL = strSQL & NewData & "');" CurrentDb.Execute strSQL MsgBox "تمت الاضافة ", , "officena" Else Response = acDataErrContinue ctl.Undo End If End Sub school.rar تحياتي
    1 point
  16. تأكد من السؤال قبل طرحه اين يوجد اكثر او أقل من 5 مرات
    1 point
  17. يمكن ان يكون المطلوب SABAH.xlsx
    1 point
  18. جرب هذا الكود اخي الكريم مع العلم بأن مسار قاعدة البيانات الحالية يكون بهذا الشكل مسار قاعدة البيانات الحالية MyPath=CurrentProject.Path لمعرفة اسم قاعدة البيانات الحالية CurrentProject.FullName الأن نبدء بالكود الخاص بنسخ الملف - اضف مربع نص و لنجعل اسمه xFile - اضف ازرار و اعطه اسم FileDialog أو اي اسم تريده و ضع الكود التالي في حدث عند النقر لاختيار الملف المراد نسخه Dim Addfile As Object Set Addfile = Application.FileDialog(3) With Addfile .AllowMultiSelect = False .InitialFileName = "" .Filters.Clear .Filters.Add "All Files", "*.*" If .Show = True Then xFile = Trim(.SelectedItems(1)) Else Exit Sub End If End With - ضع ازرار أخر و اعطه اسم مثلا | نسخ الملف المحدد | و ضع الكود ادناه في حدث عند الفتح Dim MyFile, DstFile As String Dim Syso As Object On Error GoTo errorhandle MyFile = "مسار الملف المراد نسخه" DstFile = "D:\\" مسار الملف الجديد DBEngine.Idle Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing MsgBox "تم نسخ الملف بنجاح" , vbMsgBoxRight + vbOKOnly, "تاكيد" errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit Exit Sub ErrH: Select Case Err.Number End Select و يمكن وضع مربع نص اخر لوضع مسار الملف الجديد و جعله ارتباط تشعبي ليسهل الوصول اليه
    1 point
  19. أستاذ tiger2016 الكود يعمل على كل خلايا ورقة العمل إذا كانت بها معادلات تم عمل كود ترحيل باسم ahmed أعتقد أنه يفي الغرض شيت فاتورة مبيعات A - 2 - Copy.xlsm
    1 point
  20. السلام عليكم نصيحة اخي ابتعد عن الديكورات والالوان لانه سيجعل برنامجك تقيلا وركز على الجوهر قبل المظهر ولا باس بالالوان الخفيفة البسيطة هذا اولا. ثانيا وجدت فورم بالمنتدى خزنته منذ مدة واعتقد انه للسيد العيدروس جزاه الله خيرا فيه طلبك بالتمام والكمال ان شاء الله اذا كان الفورم يحقق طلبك الغي جميع اوامر الطباعة بالصفحات لان الفورم يقوم بعملها الزرين في صفحة الطباعة المحددة هي اوامر الطباعة طبعا لم اجرب الطباعة لانه ليس لذي طابعة وانا نقلت الفورم الى ملفك فقط واي خطأ بالنتائج فليس بمقدوري اصلاحه وستجد المعونة من الخبراء ان شاء الله برنامج طباعة الشهايد.xlsb
    1 point
  21. لم افهم ماذا تقصد بعبارة لو يكون الرنج في العامود K أوسع اذا كان فصدك توزيع المواد على عدة حلايا فهذا الملف (صفحة Salim ) يفي بالغرض Aboomar_1.xlsm
    1 point
  22. ربما ينفع هذا الكود Option Explicit Sub del_Data_Val() Range("Data_Val").Validation.Delete '++++++++++Optional+++++++++++ Range("Data_Val").Value = "" End Sub '++++++++++++++++++++++++++++++++++++++ Sub Ad_Data_Val() With Range("Data_Val").Validation .Delete .Add 3, Formula1:="=Source_Rg" End With '++++++++++Optional+++++++++++ Range("Data_Val") = "" End Sub لك حرية ان تبقي على القيم الموجودة او لا بمسح ما يوجد داخل المربع الاحمر حسب هذه الصورة الملف مرفق Talal.xlsm
    1 point
  23. جرب هذا الكود Option Explicit Sub get_Std() Dim rg As Range, Cel As Range Dim Where As Range Dim dic As Object, ky, m Dim COl As Collection Set Where = Range("J4").CurrentRegion If Where.Rows.Count > 1 Then Where.Offset(1). _ Resize(Where.Rows.Count - 1) _ .ClearContents End If Set rg = Range("A4").CurrentRegion If rg.Rows.Count = 1 Then Exit Sub Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1) Set dic = CreateObject("Scripting.Dictionary") Set COl = New Collection For Each Cel In rg.Columns(3).Cells If Cel <> vbNullString Then dic(Cel.Value) = dic(Cel.Value) & Cel.Offset(, 1) & " ," On Error Resume Next COl.Add Cel.Offset(, -1), CStr(Cel.Offset(, -1)) On Error GoTo 0 End If Next If dic.Count = 0 Then Exit Sub m = 5 For Each ky In dic.keys Cells(m, "J") = COl(m - 4) Cells(m, "K") = ky Cells(m, "L") = _ Mid(dic(ky), 1, Len(dic(ky)) - 2) & "." m = m + 1 Next Set dic = Nothing: Set COl = Nothing End Sub الملف مرفق Aboomar.xlsm
    1 point
  24. السلام عليكم زيادة في الخير هذا كود كنت كتبته , ليس بروعة كود استاذنا ياسر فهو يحتاج لجدول من الاكسيل و لا يعتمد علي نفسه. تحياتي abjad+.rar
    1 point
  25. وعليكم السلام أخي الغالي خالد الرشيدي لكم يسعدني ويشرفني مرورك العطر بالموضوع ومشكور على كلماتك الرقيقة تقبل تحياتي
    1 point
  26. أخي الفاضل أبو لجين إليك الدالة التالية وإن شاء الله تفي بالغرض بالنسبة لأي طلب جديد لا يخص هذا الطلب يرجى طرح موضوع مستقل Function CalString(sInp As String) As Long Static bInit As Boolean Dim asMap() As String Dim asLtr() As String Dim I As Long Static aiVal(0 To 255) As Long If Not bInit Then asMap = Split("1 1 1 1 1 1 2 3 4 5 6 7 8 9 10 20 30 40 50 60 70 80 90 100 200 300 400 500 600 700 800 900 1000") asLtr = Split("ء أ إ آ ا ئ ب ج د ه و ز ح ط ي ك ل م ن س ع ف ص ق ر ش ت ـة ث خ ذ ض ظ غ") For I = 0 To UBound(asMap) aiVal(Asc(asLtr(I))) = asMap(I) Next I bInit = True End If For I = 1 To Len(sInp) CalString = CalString + aiVal(Asc(Mid(sInp, I, 1))) Next I End Function وإليك أيضاً ملف مرفق فيه تطبيق لاستخدام الدالة تقبل تحياتي ABJAD Calculator UDF Function YasserKhalil.rar
    1 point
×
×
  • اضف...

Important Information