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

بعد اذنك حبيبي ابا البشر انظر كده ....... جرب ووافينا بالنتيجة تنسيق المدارس1.accdb

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

السلام عليكم .. معكم ساجدة العزاوي من العراق خريجة جامعة بغداد/ علوم حاسبات / برمجة صفحتي التعليمية على الفيس بوك بعنوان ( اكسل 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

تفضل ..... Database8.rar

طلب مني احد الأصدقاء مجموعة أرقام عشوائية بدون تكرار و محصورة بين عددين مثلا 20 رقم بين 50 و 100 فتم وضع هذا الملف الذي ربما يكون له فائدة املأ الخلايا E2 و F2 و G2 بالأعداد المطلوبة و اضغط الزر الكود يقوم باحتيار الأرقام المطلوبة ب 3 طرق ترتيب تصاعدي / ترتيب تنازلي / ترتيب عشوائي """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""" يمكن استعماله في اللوتو اللبناني مثلاً ( 6 أرقام بين 1 و 42) الحد الادنى 1 قي E2 / الحد الأفصىى 42 في F2 / العدد المطلوب 6 أرقام في G2 Rand_between_without_rept.xlsm

وهذا حل ايضا بالكود على الرغم انك قد رافض هذا الأمر من البداية فلهذا موضوعك اخذ أكبر من وقته وحجمه فالموضوع ابسط من هذا بكثير -تفضل وذلك من خلال وضع هذا الكود بحدث الصفحة 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

استعمل هذا الكود !!!! Dim Warning As String Warning = MsgBox("أنت الآن على وشك التحديث فهل أنت واثق من رغبتك في التحديث", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then DoCmd.SetWarnings (False) ضع هنا استعلام التحديث المطلوب DoCmd.SetWarnings (True) Else DoCmd.CancelEvent End If

مشاركة مع حبيبي محمد ..... تفضل Allijan.accdb

السلام عليكم تم تعديل آلية الترقيات السابقة ، حيث تم اضافة شرط لعدد نقاط الاعجاب لتنفيذ الترقية الالية ، كما هو مبين أدناه الدرجة الحالية المشاركات نقاط االاعجاب عضو جديد 01 50 - 02 الأعضاء 100 10 03 عضو مميز 500 50 04 عضو فضي 1000 100 05 عضو ذهبي 1000 500 06عضو ماسي 1000 1000 عند وصول نقاط الاعجاب الي 1000 للعضو الماسي سيتم الترقية الي مجموعة أعضاء الشرف و التي تضم أيضا المكرمين من ممن لهم مساهمات خارج الموقع و ستتغير الدرجة بالترقية للأعلى بعد اول مشاركة للعضو ، و لن يتم تخفيض أي درجات حالية. و تبقي مجموعات الخبراء و فريق الموقع و فريق الموقع السابق و أعضاء الشرف دون تعديل كما سيتم قريباً بإذن الله استحداث درجة خبير مخضرم لتكون الترقية التالية لدرجة خبير و سيتم الاعلان قريبا عن موعد تطبيقها و آلية التطبيق

السلام عليكم ورحمة الله استخدم هذا الكود 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

اعرض الملف كود لقلب وضعية بلوكات كاملة طلب مني زميل حل لعكس ترتيب مجموعة من بلوكات البيانات من الوضعية الافقية الي الوضع الرأسي و ذلك دون تغيير وضعية البيانات داخل البلوك الواحد ، كما هو مبين فى الضورة يمتاز الكود بعدم مجدودية عدد البلوكات (يتم الاختيار طبقا للتظليل) و يمكن تعديله بسهولة ليناسب اعداد الاعمدة المختلفة داخل البلوك و ذلك يتعديل قيمة متغير واحد فى الكود. و لكي تستخدم هذا الكود قم اولا بتحديد عدد الأعمدة داخل كل بلوك عن طريق المتغير 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 الاقسام قسم الإكسيل  

تفضل ...... المستخدم11.mdb

حياك الله اخي @خالد عبد الغفار بالتوفيق ......

تفضل .... خالد.rar

مشاركة مع استاذي محمد tb.accdb

اكتب داخل مربع النص عدد التكرار المطلوب ------>>>> اضغط على زر عرض التقرير ..... تكرار المقطع في التقرير.mdb

وعليكم السلام -يمكنك استخدام معادلة المصفوفة(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

جرب هذا الكود بدل الموجود لديك ... 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

تفضل أخي الكريم هذا هو الكود بعد التعديل 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 لاحظ وضع مجلد الحفظ في متغير حتى لا نكرر كتابته وأيضا فحص ما إذا كان المجلد موجودا أو لا فإذا لم يكن موجودا فيتم انشاؤه ثم بعدها يتم التصدير لاجظ إضافة امتداد الملف في نهاية الاسم ولا تنسوني من صاح دعائكم

وهذا حل اخر ..... المستخدم.mdb

حياك الله اخي الكريم وبالتوفيق ...

وعليكم السلام-يمكنك استخدام هذه المعادلة بالخلية H4 سحباً للأسفل =IFERROR(INDEX($M$5:$M$8,MATCH($G6,$N$5:$N$8,0)),"") شكرا لك والحمد لله الذى بنعمته تتم الصاحات , للأسف لا امتلك قناة على اليوتيوب choose numbre1.xlsx

بعد اذن استاذنا الرائد طبعا .... على الرغم اننا نبهنا مرارا وتكرارا ان لا وجود لأى مشاركة الا بإحتوائها على ملف مدعوم بشرح كافى عن المطلوب , فغير ذلك مخالف لقوانين المنتدى وسيعرض المشاركة للحذف حيث انه يعمل على اهدار وقت الأساتذة دون جدوى كما انه لا يمكن العمل على التخمين,على الرغم من كل هذا قمت بعمل ملف لك بالمطلوب .... فعليك من البداية فتح مديول جديد ووضع هذا الكود به 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

وعليكم السلام, لماذا لا تستخدم خاصية البحث بالمنتدى -تفضل تحويل الصف الى عمود والعكس تحويل الصف إلى عامود والعامود إلى .......... وهذا فيديو ايضاً للشرح طريقتان لتحويل الصفوف لأعمدة والأعمدة لصفوف Excel Training

وعليكم السلام-تفضل حسابات المعرض1.xlsx

يمكنك استخدام معادلة المصفوفة ( 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

وعليكم السلام انظر المرفق ...... Fill_Dates.mdb

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

مع انني لا أحب ان اتعاطى مع اليوزر فورم بجميع اشكاله لكن بما انك عضو جديد فأهلاً وسهلاً بك جرب هذا الملف تم وضع كود لزر الاضافة يمكنك اضافة الأكواد لبقية الأزرار Moh_Mos.xlsm

السلام عليكم ورحمة الله ربما تقصد هذا الشكل id 2.xlsm

هناك اكثر من طريقة لعمل ذلك وهذه واحدة منها ..... افتح الاستعلام ولاحظ .... test (8) (1).accdb

جرب هذا الملف بالتفصيل Fahad Time Sheet.xlsx

تم معالجة الامر الكود 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

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

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

حرب هذا الملف 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

وعليكم السلام -تفضل عند كتابة الكود يظهر الاسم والقسم1.xlsx

أحسنت استاذ سليم عمل ممتاز بارك الله فيك وجعله فى ميزان حسناتك

تفضل يمكنك هذا بعد مشاهدة هذا الفيديو

ولو قمت بالبحث لوجدت ما تريد -تفضل , طبعاً بعد اذن الأستاذ عبد الفتاح ولإثراء الموضوع -فهذا حل اخر بالمعادلات عند فصل الإسم العربى فى خلية اخرى اذا كانت الخلية المتضمنة الإسم العربى والإنجليزى هى 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

وعليكم السلام انظر الصورة .... ادخل رقما مكان السهم بدلا من الرقم الموجود ثم انتقل بزر TAB ولاحظ الترقيم فردي.accdb

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

بارك الله فيك استاذ عبد اللطيف وزادك الله من فضله ورحم الله والديك

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

كلام صحيح ....

و عليكم السلام اخي المسافر 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

السلام عليكم هذا البرنامج من اعداد فريق عمل مايكروسوفت اكسس فيه فوائد عديدة وخاصة الاكواد المستعملة اتمنى لكم الفائدة ملاحظة -- هذا البرنامج موجود مع اكسس 2016 الطلاب مايكروسوفت.accdb

تفضل لا تنسى تغيير مسار الملف على حسب مكان التخزين 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

أكتب هذا الفانك Function azhr(Frm As String) Forms(Frm).AllowEdits = True End Function استدعية من النموذج بهذا الكود Call azhr(Me.Name)

جرب هذا حساب عمولة المندوب.xlsx