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

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


Popular Content

Showing content with the highest reputation since 11 يون, 2020 in all areas

  1. 7 points
    بعد اذنك حبيبي ابا البشر انظر كده ....... جرب ووافينا بالنتيجة تنسيق المدارس1.accdb
  2. 6 points
    أخي الكريم لاحظ الصورة ..... تجد فيه الفرز حسب الفرز الموجود في النموذج بالتوفيق .....
  3. 6 points
    السلام عليكم .. معكم ساجدة العزاوي من العراق خريجة جامعة بغداد/ علوم حاسبات / برمجة صفحتي التعليمية على الفيس بوك بعنوان ( اكسل vba برامج تطبيقات مع ساجدة العزاوي) https://www.facebook.com/sajidaalazzawi313/ قناتي على اليوتيوب متخصصة فى تقديم الشروحات فى كثير من المجالات الكومبيوتر والموبايل (سوفت وير, اكسل vba, ورد, بوربوينت, ببلشر, , شرح برامج وتنصيبها . .يوتيوب https://www.youtube.com/channel/UCSEHgnsy257rL_Wca02Tx_w من فديوهاتي سلسلة مميزة للبحث بالاسم في الفورم وهي من 13 جزء ج1 بحث بالاسم في TEXTBOX فيتم الفلترة الى LISTBOX وثم الى TEXTBOXES اكسل ساجدة العزاوي تم النشر بتاريخ 31/8/2017 ج2 بحث بالاسم زر تعديل البيانات في اليوزرفورم اكسل VBA ساجدة العزاوي تغير لغة كتابة Textbox ثلاثة اجزاء ج113 كود تغيير لغة الكتابة عربي انكليزي فرنسي تغيير مؤشر الكتابة داخل textbox ساجدة العزاوي vba تم النشر بتاريخ 14/3/2019 ج114 تغيير لغة كتابة اليوزرفورم نغيير لغة textboxe تغيير لغة keyboard عربي اكسل vba ساجدة العزاوي ج115 التحكم بلغة كتابة textbox من خلال optionbutton تغيير لغة يوزرفورم ساجدة العزاوي اكسل vba 20/3/2019 قائمة تشغيل تعلم اكسل vba https://www.youtube.com/watch?v=XGWdEThvQW4&list=PLb_hBgQ-kdgVKPF3X5dFsrFZ5l-R90wJ9
  4. 6 points
  5. 6 points
    طلب مني احد الأصدقاء مجموعة أرقام عشوائية بدون تكرار و محصورة بين عددين مثلا 20 رقم بين 50 و 100 فتم وضع هذا الملف الذي ربما يكون له فائدة املأ الخلايا E2 و F2 و G2 بالأعداد المطلوبة و اضغط الزر الكود يقوم باحتيار الأرقام المطلوبة ب 3 طرق ترتيب تصاعدي / ترتيب تنازلي / ترتيب عشوائي """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""" يمكن استعماله في اللوتو اللبناني مثلاً ( 6 أرقام بين 1 و 42) الحد الادنى 1 قي E2 / الحد الأفصىى 42 في F2 / العدد المطلوب 6 أرقام في G2 Rand_between_without_rept.xlsm
  6. 6 points
    وهذا حل ايضا بالكود على الرغم انك قد رافض هذا الأمر من البداية فلهذا موضوعك اخذ أكبر من وقته وحجمه فالموضوع ابسط من هذا بكثير -تفضل وذلك من خلال وضع هذا الكود بحدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) Dim xCellColumn As Integer Dim xTimeColumn As Integer Dim xRow, xCol As Integer Dim xDPRg, xRg As Range xCellColumn = 1 xTimeColumn = 2 xRow = Target.Row xCol = Target.Column If Target.Text <> "" Then If xCol = xCellColumn Then Cells(xRow, xTimeColumn) = Now() Else On Error Resume Next Set xDPRg = Target.Dependents For Each xRg In xDPRg If xRg.Column = xCellColumn Then Cells(xRg.Row, xTimeColumn) = Now() End If Next End If End If End Sub الحضور1.xlsm
  7. 6 points
    استعمل هذا الكود !!!! Dim Warning As String Warning = MsgBox("أنت الآن على وشك التحديث فهل أنت واثق من رغبتك في التحديث", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then DoCmd.SetWarnings (False) ضع هنا استعلام التحديث المطلوب DoCmd.SetWarnings (True) Else DoCmd.CancelEvent End If
  8. 5 points
  9. 5 points
    السلام عليكم تم تعديل آلية الترقيات السابقة ، حيث تم اضافة شرط لعدد نقاط الاعجاب لتنفيذ الترقية الالية ، كما هو مبين أدناه الدرجة الحالية المشاركات نقاط االاعجاب عضو جديد 01 50 - 02 الأعضاء 100 10 03 عضو مميز 500 50 04 عضو فضي 1000 100 05 عضو ذهبي 1000 500 06عضو ماسي 1000 1000 عند وصول نقاط الاعجاب الي 1000 للعضو الماسي سيتم الترقية الي مجموعة أعضاء الشرف و التي تضم أيضا المكرمين من ممن لهم مساهمات خارج الموقع و ستتغير الدرجة بالترقية للأعلى بعد اول مشاركة للعضو ، و لن يتم تخفيض أي درجات حالية. و تبقي مجموعات الخبراء و فريق الموقع و فريق الموقع السابق و أعضاء الشرف دون تعديل كما سيتم قريباً بإذن الله استحداث درجة خبير مخضرم لتكون الترقية التالية لدرجة خبير و سيتم الاعلان قريبا عن موعد تطبيقها و آلية التطبيق
  10. 5 points
    السلام عليكم ورحمة الله استخدم هذا الكود Sub AnalysesData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Long, j As Long, p As Long Dim Arr, Data As String Set ws = Sheets("ورقة1") Set Sh = Sheets("ورقة2") Sh.Range("B5").Resize(100, 6).ClearContents LR = ws.Range("D" & Rows.Count).End(xlUp).Row Data = Sh.Range("B2") Arr = ws.Range("B3:G" & LR).Value ReDim Preserve Arr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 4) = Data Then p = p + 1 For j = 1 To UBound(Arr, 2) Arr(p, j) = Arr(i, j) Next End If Next If p > 0 Then Sh.Range("B5").Resize(p, UBound(Arr, 2)).Value = Arr End Sub
  11. 5 points
    اعرض الملف كود لقلب وضعية بلوكات كاملة طلب مني زميل حل لعكس ترتيب مجموعة من بلوكات البيانات من الوضعية الافقية الي الوضع الرأسي و ذلك دون تغيير وضعية البيانات داخل البلوك الواحد ، كما هو مبين فى الضورة يمتاز الكود بعدم مجدودية عدد البلوكات (يتم الاختيار طبقا للتظليل) و يمكن تعديله بسهولة ليناسب اعداد الاعمدة المختلفة داخل البلوك و ذلك يتعديل قيمة متغير واحد فى الكود. و لكي تستخدم هذا الكود قم اولا بتحديد عدد الأعمدة داخل كل بلوك عن طريق المتغير CC فى الكود و فى المثال هنا عدد أعمدة كل بلوك هو 3 ـ و يمكنك تغييره كما تشاء ثم قم بتظليل كافة البيانات المراد تغيير وضعها على أن تكون عدد الاعمدة المختارة من مضاعفات الرقم المختار لأعمدة كل بلوك ثم شغل الكود Sub PivotBlocks_arafa() Dim r, c, b As Integer Dim g As String cc = 3 ' قم بتعديل هذا الرقم لتغيير عدد الاعمدة الافتراضي فى البلوك الوحد r = Selection.Rows.Count c = Selection.Columns.Count b = c / cc g = ActiveCell.Address For x = 1 To b - 1 Range(ActiveCell.Offset(0, cc * x), ActiveCell.Offset(r - 1, cc * x + cc - 1)).Cut ActiveCell.Offset(r * x - 1 + 1, 0).Activate ActiveSheet.Paste Range(g).Activate Next x End Sub صاحب الملف محمد طاهر تمت الاضافه 07 يول, 2020 الاقسام قسم الإكسيل  
  12. 5 points
  13. 5 points
    حياك الله اخي @خالد عبد الغفار بالتوفيق ......
  14. 5 points
  15. 5 points
    مشاركة مع استاذي محمد tb.accdb
  16. 5 points
    اكتب داخل مربع النص عدد التكرار المطلوب ------>>>> اضغط على زر عرض التقرير ..... تكرار المقطع في التقرير.mdb
  17. 5 points
    وعليكم السلام -يمكنك استخدام معادلة المصفوفة(Ctrl+Shift+Enter) فى الخلية J4 =INDEX($B$5:$B$9,MATCH(1,MMULT(--($C$5:$F$9=$K$4),TRANSPOSE(COLUMN($C$5:$F$9)^0)),0)) code departement1.xlsx
  18. 5 points
    جرب هذا الكود بدل الموجود لديك ... If Me.CMBSERIAL.Column(0) = DLookup("IDD", "EMPDEV", "[IDD] = '" & Me.CMBSERIAL.Column(0) & "'") Then Me.CMBSERIAL.Undo Me.Undo MsgBox "هذا الجهاز مسجل مسبقاً", vbInformation, "تنبيه التكرار" Exit Sub Else MsgBox "تم" End If
  19. 5 points
    تفضل أخي الكريم هذا هو الكود بعد التعديل Sub Export_PDF_in_OneAll() Application.ScreenUpdating = False Sheets(Array("Report")).Select mypath = "D:\USP41 - NF36\" & Range("C9").Value If Dir(mypath, vbDirectory) = "" Then MkDir mypath ActiveSheet.ExportAsFixedFormat xlTypePDF, mypath & "\" & Range("c8").Value & ".pdf", xlQualityStandard Worksheets("Report").Select Application.ScreenUpdating = True MsgBox "Done" End Sub لاحظ وضع مجلد الحفظ في متغير حتى لا نكرر كتابته وأيضا فحص ما إذا كان المجلد موجودا أو لا فإذا لم يكن موجودا فيتم انشاؤه ثم بعدها يتم التصدير لاجظ إضافة امتداد الملف في نهاية الاسم ولا تنسوني من صاح دعائكم
  20. 5 points
  21. 5 points
    حياك الله اخي الكريم وبالتوفيق ...
  22. 5 points
    وعليكم السلام-يمكنك استخدام هذه المعادلة بالخلية H4 سحباً للأسفل =IFERROR(INDEX($M$5:$M$8,MATCH($G6,$N$5:$N$8,0)),"") شكرا لك والحمد لله الذى بنعمته تتم الصاحات , للأسف لا امتلك قناة على اليوتيوب choose numbre1.xlsx
  23. 5 points
    بعد اذن استاذنا الرائد طبعا .... على الرغم اننا نبهنا مرارا وتكرارا ان لا وجود لأى مشاركة الا بإحتوائها على ملف مدعوم بشرح كافى عن المطلوب , فغير ذلك مخالف لقوانين المنتدى وسيعرض المشاركة للحذف حيث انه يعمل على اهدار وقت الأساتذة دون جدوى كما انه لا يمكن العمل على التخمين,على الرغم من كل هذا قمت بعمل ملف لك بالمطلوب .... فعليك من البداية فتح مديول جديد ووضع هذا الكود به Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _ ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Public Const VK_SNAPSHOT = 44 Public Const VK_LMENU = 164 Public Const KEYEVENTF_KEYUP = 2 Public Const KEYEVENTF_EXTENDEDKEY = 1 وبعد تصميم الفورم عليك بوضع هذا الكود به للطباعة Private Sub CommandButton1_Click() DoEvents keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + _ KEYEVENTF_KEYUP, 0 keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + _ KEYEVENTF_KEYUP, 0 DoEvents Workbooks.Add Application.Wait Now + TimeValue("00:00:01") ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, _ DisplayAsIcon:=False ActiveSheet.Range("A1").Select With ActiveSheet.PageSetup .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With ActiveWindow.SelectedSheets.PrintOut Copies:=1 ActiveWorkbook.Close False End Sub وهذا هو الملف print Userform.xlsm
  24. 5 points
    وعليكم السلام, لماذا لا تستخدم خاصية البحث بالمنتدى -تفضل تحويل الصف الى عمود والعكس تحويل الصف إلى عامود والعامود إلى .......... وهذا فيديو ايضاً للشرح طريقتان لتحويل الصفوف لأعمدة والأعمدة لصفوف Excel Training
  25. 5 points
  26. 5 points
    يمكنك استخدام معادلة المصفوفة ( Ctrl+Shift+Enter) .... من أعمال استاذنا سليم حاصبيا له منا كل المحبة والإحترام =IFERROR(IF(ROW($C$2)>SUM($C$2),"",INDEX($A$2:$A$100,MATCH(FALSE, COUNTIF($E$1:E1,$A$2:$A$100)=$C$2,0))),"") 81.xlsx
  27. 5 points
  28. 5 points
    هو كما ذكرت ولكن نسيت أن اعدل جدول الاحتياج كما في الصورة .... لأن هذا العدد يتناقص كل ما تم توزيع الطلاب ..... عدله كما في الصورة
  29. 5 points
    مع انني لا أحب ان اتعاطى مع اليوزر فورم بجميع اشكاله لكن بما انك عضو جديد فأهلاً وسهلاً بك جرب هذا الملف تم وضع كود لزر الاضافة يمكنك اضافة الأكواد لبقية الأزرار Moh_Mos.xlsm
  30. 5 points
  31. 5 points
    هناك اكثر من طريقة لعمل ذلك وهذه واحدة منها ..... افتح الاستعلام ولاحظ .... test (8) (1).accdb
  32. 5 points
  33. 5 points
    تم معالجة الامر الكود Option Explicit Sub Get_ALL() Dim Arr(), m, I, itm Dim Ro%, Col%, My_sum# Dim k% m = 1 Principal.Range("B7:B13").ClearContents If Application.CountA(Principal.Range("B4:B6")) < 3 Then MsgBox "Incomplete Data" & Chr(10) & _ "Ckeck Up For Empty The Cells,B4,B5,And B6" Exit Sub End If If Principal.Range("B4") > Sheets.Count - 1 Then Principal.Range("B4") = 1 End If If Principal.Range("B5") > Sheets.Count - 1 Then Principal.Range("B5") = Sheets.Count - 1 End If If Principal.Range("B5") < Principal.Range("B4") Then Principal.Range("B5") = Principal.Range("B4") End If m = 1 For I = Principal.Range("B4") To Principal.Range("B5") ReDim Preserve Arr(1 To m) Arr(m) = Sheets(Principal.Range("B4") + m).Name m = m + 1 Next '++++++++++++++++++++++++++++++++++ For k = 7 To 13 For Each itm In Arr Ro = Sheets(itm).Range("B4:B21").Find(Principal.Range("B6"), lookat:=1).Row Col = Sheets(itm).Range("C3:Z3").Find(Principal.Range("A" & k), lookat:=1).Column + 2 My_sum = My_sum + Val(Sheets(itm).Cells(Ro, Col)) Next itm Principal.Range("B" & k).Value = My_sum My_sum = 0 Next k End Sub الملف مرفق MaKhazin.xlsm
  34. 4 points
    وعليكم السلام ورحمة الله وبركاته اولا تحية لاستاذنا العلامة عبدالله باقشير .نسأل الله ان تكون اعماله في ميزان حسناته وصدقة جاريه له ولاهله واحبابه. اخي الفاضل محاولة ربما يكون فيها طلبك الاختيار من الكمبوكس بنفس الفورم لم اتمكن من عملها ولكن قمت بعمل كمبوكس في فورم اخر تحياتي فورم ادخال و تعديل مرن بمعية فورم ادخال التاريخ.xlsm
  35. 4 points
    احد حلول فتح كل نموذج و تقرير على حسب معايير مربعات تحرير و سرد المستخدم.rar
  36. 4 points
    حرب هذا الملف Option Explicit Sub Get_Color() Dim My_Regex As Object Dim x%, m%, La%, t% Dim arrWords, Arr() ReDim Arr(4) Arr(0) = 3: Arr(1) = 14: Arr(2) = 5: Arr(3) = 3 Set My_Regex = CreateObject("VBScript.RegExp") My_Regex.Pattern = "(\d{3})" My_Regex.Global = True With Sheets("Sheet1") La = .Cells(Rows.Count, 3).End(3).Row m = 1 With .Range("E6:E" & La) .Font.ColorIndex = 1 .ClearContents End With For t = 6 To La .Range("E" & t) = .Range("C" & t) If My_Regex.test(.Range("E" & t)) Then Set arrWords = My_Regex.Execute(.Range("E" & t)) For x = 0 To arrWords.Count - 1 Range("E" & t).Characters(m, 3) _ .Font.ColorIndex = Arr(x) m = m + 3 Next x End If m = 1 Next t End With End Sub الملف مرفق Abbadi.xlsm
  37. 4 points
    وعليكم السلام -تفضل عند كتابة الكود يظهر الاسم والقسم1.xlsx
  38. 4 points
    أحسنت استاذ سليم عمل ممتاز بارك الله فيك وجعله فى ميزان حسناتك
  39. 4 points
    تفضل يمكنك هذا بعد مشاهدة هذا الفيديو
  40. 4 points
    ولو قمت بالبحث لوجدت ما تريد -تفضل , طبعاً بعد اذن الأستاذ عبد الفتاح ولإثراء الموضوع -فهذا حل اخر بالمعادلات عند فصل الإسم العربى فى خلية اخرى اذا كانت الخلية المتضمنة الإسم العربى والإنجليزى هى A2 , فيمكنك استخدام معادلة المصفوفة بالخلية B2 (Ctrl+Shift+Enter) =MID(A2,MATCH(1,IF(CODE(MID(A2,ROW(INDIRECT("1:"&LEN(A2))),1))>=192,1),0),255) اما بالنسبة للإسم الإنجليزى فيكون بهذه المعادلة داخل الخلية C2 كما بالملف =TRIM(LEFT(A2,LEN(A2)-LEN(B2))) فصل الكلمات العربية عن الانجليزية Seperate Mix Text.xlsm
  41. 4 points
    وعليكم السلام انظر الصورة .... ادخل رقما مكان السهم بدلا من الرقم الموجود ثم انتقل بزر TAB ولاحظ الترقيم فردي.accdb
  42. 4 points
    ممكن الاستفادة من الفكرة هنا ..... بالتوفيق ....
  43. 4 points
    بارك الله فيك استاذ عبد اللطيف وزادك الله من فضله ورحم الله والديك
  44. 4 points
    السلام عليكم 🙂 اما انا فأتفق مع اخوي عبداللطيف ان هذه المعلومات متوفرة في الانترنت ، واللي يريد هذا الشيء يمكنه الحصول عليها 🙂 ولكن اللي ما اتفق فيه مع اخوي عبداللطيف هو مخالفة قوانين المنتدى بوضع السيريال في البرنامج المرفق ، مما يجعله "مخالف لحقوق الملكية الفكرية" للبرنامج المرفق ، لذا وجب حذف رابط التحميل 🙂 جعفر
  45. 4 points
  46. 4 points
    و عليكم السلام اخي المسافر 2006 لعمل ذلك ضع الكود التالي في حدث عند النقر لزر التفاصيل DoCmd.OpenForm "NamesRecord", , , "[السجل المدني]=" & Me.السجل_المدني If Forms!NamesRecord!الرتبة <> "جندي" And Forms!NamesRecord!الرتبة <> "جندي اول" And _ Forms!NamesRecord!الرتبة <> "عريف" And Forms!NamesRecord!الرتبة <> "وكيل رقيب" And _ Forms!NamesRecord!الرتبة <> "رقيب" And Forms!NamesRecord!الرتبة <> "رقيب اول" And _ Forms!NamesRecord!الرتبة <> "رئيس رقباء" Then Forms!NamesRecord![رقم الملف].Visible = flase Forms!NamesRecord![السجل المدني].Visible = flase Forms!NamesRecord![الإختصاص].Visible = flase Forms!NamesRecord![تاريخ الميلاد].Visible = flase Forms!NamesRecord![تاريخ التعيين].Visible = flase Forms!NamesRecord![تاريخ اخر ترقية].Visible = flase Forms!NamesRecord![تاريخ استحقاق الترقية].Visible = flase Forms!NamesRecord![المؤهل الدراسي].Visible = flase Forms!NamesRecord![السرية].Visible = flase Forms!NamesRecord![الفصيل].Visible = flase Forms!NamesRecord![العنوان].Visible = flase Forms!NamesRecord![اسم شخص قريب].Visible = flase Forms!NamesRecord![جوال القريب].Visible = flase End If تفضل المرفق مع ملاحظة اني غيرت اسم النموذج المراد فتحه الى NamesRecord و انصحك بالتسمية باللغة الانجليزية و بدون ترك مسافات بين الاسماء لتفادي المشاكل البرمجية اضافة الى ان هذا يسهل عليك فهم الاكواد و التعبيرات في الاكسس ( حتى و لو كانت التسمية بالترجمة الحرفيه ) بالتوفيق ss.rar
  47. 4 points
    السلام عليكم هذا البرنامج من اعداد فريق عمل مايكروسوفت اكسس فيه فوائد عديدة وخاصة الاكواد المستعملة اتمنى لكم الفائدة ملاحظة -- هذا البرنامج موجود مع اكسس 2016 الطلاب مايكروسوفت.accdb
  48. 4 points
    تفضل لا تنسى تغيير مسار الملف على حسب مكان التخزين Sub Test() Dim sr As Workbook Set sr = Workbooks.Open("C:\Users\alhagag\Downloads\touati\touati1.xlsx", True, True) ThisWorkbook.Activate Worksheets("sheet1").Range("B2:E200").Value = sr.Worksheets("sheet1").Range("a2:d200").Value sr.Close End Sub touati.rar
  49. 4 points
    أكتب هذا الفانك Function azhr(Frm As String) Forms(Frm).AllowEdits = True End Function استدعية من النموذج بهذا الكود Call azhr(Me.Name)
  50. 4 points


×
×
  • اضف...