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

في دروس سابقة تناولنا معا بعض الحيل والافكار حول استخدام اليوزر فورم لتسهيل وتيسير ما امكن لانجاز الأعمال النهاردة فكرتنا حول استخدام الفورم في حالة الاصناف الكثيرة المتشابهة كقطع غيار السيارات والاكترونيات ....... الخ وهي عمل قائمة شقية خفيفة متنقلة تعطيك احساس التفاعل والراحة البصرية تظهر عند الضغط علي صنف معين لتظهر صورة الصنف وتفاصيله او وصفه ... الخ استخدمت مثال بسيط لتوصيل الفكرة وان شاء الله تكون فيها الفائدة والنفع اسيبكم لتجربة الملف واي استفسار او ملاحظة يسعدني ووفقنا الله واياكم للخير الملف بالمرفقات مع ملاحظة وضع ملف (PicForm) علي القسم (D) مباشرة او قم تغير مسار الصور في في الملف حسب مكانه عندك How to create Pop-up form in Excel Userform.xlsm ملف الصور قم بفك الضغط وحفظه علي مسار Dمباشرة PicForm.rar

عليكم السلام عسى ولعل يكون المطلوب Sub test() Dim a, x, w Dim i& Dim sht As Worksheet x = Array("المخزن", "المدخلات", "الفاتورة", "Sheet1", "بيان الأرباح") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With CreateObject("scripting.dictionary") For Each sht In ActiveWorkbook.Worksheets If IsError(Application.Match(sht.Name, x, 0)) Then a = sht.Cells(8, 1).Resize(sht.Cells(Rows.Count, 1).End(xlUp).Row - 7, 7) For i = 1 To UBound(a) If Not .exists(a(i, 2)) Then .Add a(i, 2), Array(a(i, 4), a(i, 3) * a(i, 4), a(i, 7)) Else w = .Item(a(i, 2)) w(0) = w(0) + a(i, 4): w(1) = w(1) + a(i, 3) * a(i, 4): w(2) = w(2) + a(i, 7) .Item(a(i, 2)) = w End If Next End If Next For i = 5 To Range(Cells(5, 2), Cells(5, 2).End(xlDown)).Count If Cells(i, 2) = "" Then Exit Sub If Not .exists(Cells(i, 2)) Then Cells(i, 3).Resize(, 3) = .Item(Cells(i, 2).Value) Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub بيان الأرباح.rar

بما انك مصر على نفس الفكرة ونفس اليوزرفورم تفضل اخي يمكنك تغيير الاكواد بالشكل التالي تمت اظافة كومبوبوكس لاختيار عمود البحث و تكست بوكس للبحث بالحروف الاولى Dim f, rng, MH(), Ncol '21/02/2022 اوفيسنا Private Sub UserForm_Initialize() Dim ST Set f = Sheets("Follow up") Set rng = f.Range("A5:J" & f.[A65000].End(xlUp).Row) MH = rng.Value ST = f.[A4].CurrentRegion.Columns.Count Me.ListBox1.ColumnCount = ST Set plage = f.[A4].CurrentRegion Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1) x = Me.ListBox1.Left + 8 y = Me.ListBox1.Top - 12 For i = 1 To ST Set Lab = Me.Frame1.Controls.Add("Forms.Label.1") Lab.Caption = f.Cells(4, i) Lab.Top = y Lab.Left = x x = x + f.Columns(i).Width * 1.02 temp = temp & f.Columns(i).Width * 1.02 & ";" Next temp = Left(temp, Len(temp) - 1) Me.ListBox1.ColumnWidths = temp Me.Frame1.ScrollWidth = Me.ListBox1.Width + 10 Me.Frame1.ScrollBars = 1 ' Me.ListBox1.List = plage.Value ' يمكنك تفعيل هدا الخيار لاظهار البيانات على الليست بوكس Me.ComboChoixColFiltre.List = Application.Transpose(rng.Offset(-1).Resize(1)) Me.ComboChoixColFiltre.ListIndex = 0 Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboChoixColFiltre_click() Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub CommandButton1_Click() If Recherche.Value = Empty Then MsgBox "المرجوا ادخال معيار البحث", vbInformation + vbMsgBoxRight + vbMagBoxRt1Reading, "تعليمات" Exit Sub End If colRecherche = Me.ComboChoixColFiltre.ListIndex + 1 clé = "*" & Me.Recherche & "*": N = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, colRecherche) Like clé Then N = N + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To N) For k = 1 To UBound(MH, 2): Tbl(k, N) = MH(i, k): Next k End If Next i If N > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Recherche_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then Recherche.Value = Empty End If End Sub ملاحظة البحث يكون فقط على نفس الشيت Test_User.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب مصنف2.xlsx

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

السلام عليكم ورحمة الله وبركاته استاذي محمد Mohamed Hicham ما شاء الله تبارك الله كود جميل وفكر رائع ( لا زلت احلله واتعلم منه ما شاء الله). أوافقكم الرأي بوجوب توضيح المطلوب وتحديدها وهو ما حاول Goldkamel أن يعرضه من خلال ملفين الأول متعلق بالصيانة ، والآخر متعلق ببيانات مدرسية. مع أن الهذف لازال غير واضح، مع لذلك وحسب فهمي لمطلوب وبعد الاستفادة مما طرحه الاستاذ محمد هشام ، ارفق لكم ملفين الأول متعلق بالصيانة والاخر متعلق ببيانات مدرسية اجتهدت أن تكون وفق المراد. يمكن تحديد ثلاث عناصر للبحث، ويمكن اختيار اي عمود للبحث فيه، مع الحرية في تحديد البيانات التي ترغب في عرضها في القائمة كنتيجة لعملية البحث. ملاحظات: مع اسفي على تشتتي بين الملفات المرفوعة ومحاولة تحديد المطلوب مع تقديم المقترح في ردي الأول بأهمية وجود ورقة (Prime) تتضمن القوائم التي من خلالها يتم توحيد الادخال والبحث والمعالجة لتجنب الأخطاء المطبعية عند الادخال أو البحث، وعند الرغبة في البحث في اكثر من ورقة فيجب مراعاة توحيد الأعمدة في جميع أوراق العمل. بحث بشرطين kml2.xlsm البحث فى كل اوراق العمل.xlsb

هل ستتحف اخوتك بنسخة من البرنامج ؟ ام هذا اعلان ؟

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته شرح تفصيلي لأداة ال ListView وكيفية استخدامها والتعامل معها بعد العديد من لاستفسارات حول أداة ال ListView في البدء سنتعلم كيف تتم إضافة الأداة , من قائمة Additional Controls كما في الصور التالية : صورة الأداة بعد إضافتها على ال Form خصائص الأداة وسوف نتعرف علي استخدمها تباعا بالتفصيل استخدامات أداة ال ListView أولاً : استخدام أداة ال ListView كأداة لعرض البيانات من استخدامات أداة ال ListView هو استخدامها كأداة لعرض البيانات مثل أداة DataGrid وأداة MSFlexGrid المعروفة. لاستخدام أداة ال ListView كأداة لعرض البيانات يجب ضبط خاصية View على الخيار lvwReport ,طبعاً خاصية View تستخدم لتحديد أسلوب العرض في أداة ال ListView وهناك خيارات أخرى لأسلوب العرض وهذه الخيارات هي كما يلي ■ lvwIcon : وهي لعرض أيقونات كبيرة داخل أداة ال ListView . ■ lvwList : وهي البيانات كقائمة داخل أداة ال ListView . ■ lvwReport : وهي لعرض البيانات كتقرير داخل أداة ال ListView وهي تشبه كثيراً الأدوات المعروفة لعرض البيانات من قاعدة البيانات مثل أداة DataGrid وأداة MSFlexGrid … الخ. وهي أكثر الخيارات المستخدمة من قبل المبرمجين . ■ lvwSmallIcon : وهي لعرض أيقونات صغيرة داخل أداة ال ListView أبدأ الآن بمثال بسيط لا يعتمد على قاعدة البيانات تابع معي 1)أضف أداة ListView إلى الForm 2)اذهب إلى حدث UserForm_Activateواكتب الكود التالي , وهذا الكود كما شرحنا سابقاً لتحديد أسلوب العرض في أداة ال ListView . Private Sub UserForm_Activate() Me.ListView1.View = lvwReport End Sub 3)لنفترض أن نريد إضافة ثلاثة أعمدة داخل أداة ال ListView في هذه الحالة يجب إضافة عنوان رأسي لكل عمود وهذا يتم باستخدام خاصية ColumnHeaders لأداة ال ListView ◄ قبل إضافة العناوين الرأسية لأداة ال ListView سأشرح خاصية ColumnHeaders لهذه الخاصية خمس وظائف وهي كالتالي ♦ Add : وهي الوظيفة تستخدم لإضافة عنوان رأسي داخل أداة ال ListView ولهذه الخاصية ست باراميترات وهي كما يلي ListView1.ColumnHeaders.Add Index, Key, Text, Width, Alignment, Icon حيث ▪ Index : هي الفهرس لهذا العنوان الرأسي ▪ Key : المفتاح لهذا العنوان الرأسي ▪ Text: النص الذي سيظهر عليه وهو الباراميتير الوحيد الذي سأستخدمه في إضافة العناوين الرأسية ▪ Width: لتحديد عرض العنوان الرأسي ▪ Alignment : لتحديد اتجاه محاذاة النص على العنوان الرأسي ولهذه الخاصية ثلاثة قيم lvwColumnLeft = 0 lvwColumnRight = 1 lvwColumnCenter = 2 مع ملاحظة أن العمود الأول في أداة ال ListView تكون قيمة ال Alignment = 0 أي النص محاذاة النص دائماً له تكون على اليسار ▪ Icon: وهي خاصية لإضافة أيقونات للعناوين الرأسية.مع مراعاة ضبط خاصية ColumnHeaderIcons باسم أداة ال ImageList التي يتم إدراج الصور منها كما في الكود التالي ListView1.ColumnHeaderIcons = ImageList1 ♦ Clear : وتستخدم هذه الوظيفة لمسح جميع العناوين الرأسية الموجودة داخل أداة ال ListView كما في الكود التالي ListView1.ColumnHeaders.Clear ♦ Count : وتستخدم هذه الوظيفة لجلب عدد العناوين الرأسية الموجودة داخل أداة ال ListView كما في الكود التالي مثلاً MsgBox ListView1.ColumnHeaders.Count ♦ Remove : وتستخدم هذه الوظيفة لحذف عنوان رأسي معين بناء على قيمة ال Index لهذا العنوان كما في الكود التالي ListView1.ColumnHeaders.Remove Index حيث قيمة ال Index لأول عنوان رأسي في هذه الحالة = 1 وباقي العناوين بنفس الطريقة مع زيادة ال Index بمقدار 1 للعنوان الرأسي الذي يليه ♦ Item : وظائف هذه الأداة هي نفسها باراميترات الوظيفة Add فقط هناك وظيفتين جديدتين وهما ▪ Position : وهي لتحديد رقم العنوان الرأسي ▪ SubItemIndex : وهي لتحديد رقم ال Index للعناصر الموجود أسفل هذا العنوان الرأسي 4) بعد أن شرحنا وظائف الخاصية ColumnHeaders كما قلنا سابقاً نقوم بتحديد أسلوب العرض في أداة ال ListView من خلال الخاصية View كما يلي Private Sub UserForm_Activate() Me.ListView1.View = lvwReport End Sub 4) نقوم بإضافة ثلاث عنوانين رأسية ليصبح الكود كما يلي Private Sub UserForm_Activate() ListView1.View = lvwReport ListView1.ColumnHeaders.Add , , "Name" ListView1.ColumnHeaders.Add , , "Number" ListView1.ColumnHeaders.Add , , "Address" End Sub 5) قم بتشغيل المثال ستلاحظ تغير شكل ال ListView ليصبح كما في الصورة التالية 6)نأتي الآن لإضافة بيانات داخل أداة ال ListView , لإضافة عناصر داخل أداة ال ListView نستخدم خاصية ListItems ولهذه الخاصية خمس وظائف أيضاً وهي كالتالي ♦ Add : وهي الوظيفة تستخدم لإضافة بيانات داخل أداة ال ListView ولهذه الخاصية خمس باراميترات وهي كما يلي ListView1.ListItems.Add Index, Key, Text, Icon, SmallIcon ▪ SmallIcon : وهي خاصية لإضافة أيقونات للعناصر ,مع مراعاة ضبط خاصيةIcons باسم أداة ال ImageList التي يتم إدراج الصور منها كما في الكود التالي وهذه هي الخاصية التي سنستخدمها في هذه الحالة. ♦ Clear : وتستخدم لحذف محتويات الListView ♦ Count : وتستخدم لمعرفة عدد الصفوف داخل أداة ال ListView ♦ Remove : وتستخدم لحذف صف معين في أداة ال ListView مع العلم أن قيمة ال Index لأول سطر = 1 ♦ Item : ولها العديد من الخصائص وأهم هذه الخصائص هي ▪ Bold : وهي لجعل الخط غامق وهي خاصية منطقية ترجع قيمة إما True أو False ▪ Checked : وهي خاصية لوضع علامة صح أمام العنصر داخل أداة ال ListView طبعاً في هذه الحالة يجب ضبط خاصية Checkboxes = True لأداة ال ListView كما في الكود التالي ListView1.Checkboxes = True ▪ ForeColor : لتغيير لون الخط لعنصر معين داخل أداة ال ListView ▪ Selected : لتحديد صف معيّن وهي خاصية منطقية ترجع قيمة إما True أو False ●طبعاً في وظيفة Add كلما أضفنا عنصر بالصيغة الموجودة في الأعلى يتمإضافته في نفس العمود .. إذن كيف سنضيف بيانات في الأعمدة الأخرى ؟ تابع معي .. نقوم بتعريف متغير من نوع ListItem ونقوم بإسناده إلى الوظيفة Addثم نستخدم هذا المتغير في إضافة بيانات للأعمدة الأخرى كما يلي Private Sub UserForm_Activate() Dim Lst As ListItem Set Lst = ListView1.ListItems.Add(, , "Dahy Algharieb") Lst.ListSubItems.Add , , "Officana" Lst.ListSubItems.Add , , "Excel" End Sub ● كما هو الحال بالنسبة للخاصية ListItems فإن الخاصية ListSubItems لها نفس الوظائف فالصيغة العامة لوظيفة Add هي كما يلي Lst.ListSubItems.Add Index, Key, Text, ReportIcon, ToolTipText كما تلاحظ في البارميترات فالوظيفة Add للخاصية ListSubItems هي تقريبا نفسها البارميترات للوظيفة Add للخاصية ListItems ف ReportIcon هي نفسها SmallIcon والباراميتر ToolTipText فهو للنافذة الصغير المنبثقة عند وضع مؤشر الفأرة على ذلك العنصر. 7)نأتي الآن لنضيف بيانات داخل أداة ال ListView هناك أيضاً خصائص أخرى لأداة ال ListView يمكنك استخدامها أيضاً كما يلي ● Appearance : وهي لتحديد مظهر أداة ال ListView ولها قيمتين وهما ccFlat لجعل أداة الListView مسطحة و cc3D وهي لجعل أداة الListView ثلاثية الأبعاد. ● BackColor : لتغيير لون خلفية أداة ال ListView . ● FlatScrollBar : لتحديد مظهر أشرطة التمرير لأداة ال ListView وهي خاصية ذات قيمة منطقية . ● ForeColor : لتحديد لون الخط . ● GridLines : وهي خاصية لجعل أداة ال ListView كالشبكة وهي خاصية ذات قيمة منطقية. ● HideColumnHeaders : وهي لإخفاء العناوين الرأسية وهي خاصية ذات قيمة منطقية. ● HotTracking : وهي خاصية لتتبع شريط التحديد وهي خاصية ذات قيمة منطقية. ● HoverSelection : وهذه الخاصية عند تفعيلها يتم وضع شريط التحديد على الصف الذي يمر عليه مؤشر الفأرة. ● MultiSelect : وهذه الخاصية تستخدم لتحديد أكثر من صف في نفس الوقت وهي خاصية منطقية. ● Picture : وهي لوضع خلفية لأداة ال ListView . ● PictureAlignment : وهي لتحديد محاذاة خلفية ال ListView . ● Sorted : يتم ضبط هذه الخاصية لتساوي True لترتيب العناصر. ● SortKey : تستخدم هذه الخاصية لتحديد رقم العمود الذي نريد ترتيب البيانات بواسطته حيث رقم أو عمود هو 0 ● SortOrder : تستخدم هذه الخاصية لتحديد نمط ترتيب العناصر داخل ال ListView ولها قيمتين وهما lvwAscending لترتيب العناصر بشكل أبجدي تصاعدياً و lvwDescending لترتيب العناصر بشكل أبجدي تنازلياً . مثال عملي علي ListView وبالتوفيق للجميع المثال مع الشرح بالمرفقات ListView.xlsm رابط الدرس الثاني ListView Right to Left الدرس الثاني

فى هذا البرنامج نعرف مواصفات جهاز الكمبيوتر لم أستطيع التوصل الى نوع الرام DDR2 أو DDR3 ,,وهكذا . لم أستطيع التوصل الى حجم كارت الشاشة . لم أستطيع التوصل الى نواة الويندوذ هل هى X32 أو X68 مرجب بالتجربة و مرحب بالتطوير ان أمكن SystemInfo.rar

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

تفضل لكن الطريقة هذي فيها ثغرة الآن الترقيم في الجدول مترتب فلو اختلف ظهرت لخبطة فالافضل اخذ الرقم x من مجموعة السجلات اسم العميل2.rar

ما شاء الله تبارك الرحمن 🙂 شكرا جزيلا أخي @محمد احمد لطفى .. جمعت كل أصحابنا المطلوبين في فورم واحد 😄 بس يارت لو تعمل حساب الأجهزة ذات النواة 64 بت .. لأن كثير من الدوال تشتغل على ال 32 بت فقط 🙂

تم اضافة نوع الرام تم اضافة نواة الويندوذ تم تغيير كود Pubic Ip و IP تم اضافة حفظ البيانات فى جداول عند التشغيل فى حالة أن تكون في فلاشة فى الجهاز بيانات الهارد تكون الفلاشة (حجم الهارد و عدد البارتشن) خطأ مازال جارى البحث عن حجم كارت الشاشة صورة من جهازى و فى حالة وجدت شيء أخر سأحدث الموضوع , وشكراً لأعضاء المنتدى الكرماء SystemInfo.rar

استخدم هذه الاداة لولدنا العزيز الاستاذ @Moosak

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

السلام عليكم و رحمة الله بارك الله فيك دائم الابداع

بارك الله

جرب هذا عمر 🙂 On Error GoTo HandleError Dim ObjName As String Select Case ObjName Case Is = "FrmAddNewPOTally" If CurrentProject.AllForms(ObjName).IsLoaded Then txtLPOID = Forms![FrmAddNewPOTally]![cbIDPO] If DLookup("[LPOID]", "[TblChicPO]", "[LPOID] =" & [Forms]![FrmAddNewPOTally]![cbIDPO] & "") = txtLPOID Then Call LodInfo cmdEdit.Enabled = True Else MsgBox "DataBase Not Have Any Information For List Document For PO ID# " & txtLPOID, vbCritical, "Worning" cmdSave.Enabled = True End If End If Case Is = "FromPoTallySearch" If CurrentProject.AllForms(ObjName).IsLoaded Then txtLPOID = Forms![FromPoTallySearch]![SubFromPoTally].Form![txtIDPO] If DLookup("[LPOID]", "[TblChicPO]", "[LPOID] =" & [Forms]![FrmAddNewPOTally]![cbIDPO] & "") = txtLPOID Then Call LodInfo cmdEdit.Enabled = True Else MsgBox "DataBase Not Have Any Information For List Document For PO ID# " & txtLPOID, vbCritical, "Worning" cmdSave.Enabled = True End If End If End Select HandleExit: Exit Sub HandleError: If Err.Number = 0 Then Exit Sub ElseIf Err.Number = 2467 Then Exit Sub ' ElseIf Err.Number = 2478 Then ' Exit Sub Else MsgBox Err.Number & vbNewLine & vbNewLine & Err.Description End If Resume HandleExit

هو رقم العقد بيكون كام رقم ؟ وايه هيئته ؟ علشان ممكن اقترح عليك تقسم الرقم على حقلين لو افترضنا ان الرقم عباره عن السنه والشهر ورقم العقد مثل 202301999999999 فيمكن جعل الحقل الاول يحمل السنه والحقل الثاني يحمل الشهر (او الحقل الاول يحمل السنه والشهر معا) والحقل الثالث تجعله لرقم العقد

تفضل عسى يكون المطلوب Sub test() Dim a Dim i&, ii&, nn&, x&, xx& Dim myArea As Range With Sheets("الرئيسية اول") a = Range(.Cells(6, 1), .Cells(6, 3).End(xlDown)).Cells nn = .Cells(2, 7) End With For i = 2 To Sheets.Count - 1 With Sheets(i) x = 1: xx = 0 For ii = 0 To UBound(a) / nn .Cells(6 + xx, 1).Resize(30, 3).ClearContents .Cells(6 + xx, 1).Resize(nn, 3).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + nn - 1 & ")"), [{1,3,2}]), "") x = x + nn: xx = xx + 41 Next End With Next End Sub

بارك الله

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

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

سبحان الله العظيم وبحمده تم النشر بتاريخ ٢٣ أكتوبر سنه 2021 واليوم ٢١ فبراير سنه ٢٠٢٣ فأكيد المعادله زعلت 🧐 هلا ارفقت ملف اخى

السلام عليكم ورحمة الله اولا : ضع الكود التالى فى موديول مستقل و خصص له زر Sub NewTopTen() Dim ws As Worksheet, LR As Long Dim Arr(), Tmp(), n As Integer, Rnk As String Dim i As Integer, j As Integer, p As Integer Dim Num As Integer, y As Integer Const Rep As String = "مكرر" Dim WF As WorksheetFunction, C As Range Set ws = Sheets("ورقة البيانات") Set WF = WorksheetFunction LR = ws.Range("C" & Rows.Count).End(3).Row ReDim Preserve Arr(1 To LR, 1 To 1) For Each C In ws.Range("U8:U" & LR) y = WF.CountIf(ws.Range(ws.Cells(8, "U"), _ ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U")) If y = 1 Then p = p + 1 Arr(p, 1) = C.Value End If Next If p < 50 Then n = p - 1 Else n = 50 End If For i = 1 To n Num = WF.Large(Arr, i) For Each C In ws.Range("U8:U" & LR) If C.Value = Num Then Rnk = TextNums(i) C.Offset(0, 1) = Rnk x = WF.CountIf(ws.Range(ws.Cells(8, "U"), _ ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U")) If x > 1 Then Rnk = TextNums(i) & " " & Rep C.Offset(0, 1) = Rnk End If End If Next Next End Sub ثانيا : اما هذه الدالة المخصصة ضعها ايضا فى موديول اخر و لا تتعامل معها مرة اخرى حتى يعمل معك الكود الاول بكفاءة Function TextNums(Num As Integer) As String Dim Ar, Tp, Reslt As String Dim m As Integer Ar = Array("الاول", "الثانى", "الثالث", "الرابع", "الخامس", "السادس", "السابع", _ "الثامن", "التاسع", "العاشر", "الحادى عشر", "الثانى عشر", "الثالث عشر", _ "الرابع عشر", "الخامس عشر", "السادس عشر", "السلبع عشر", "الثامن عشر", _ "التاسع عشر", "العشرين", "الحادى و العشرين", "الثانى و العشرين", _ "الثالث و العشرين", "الرابع و العشرين", "الخامس و العشرين", "السادس و العشرين", _ "السابع و العشرين", "الثامن و العشرين", "التاسع و العشرين", "الثلاثين", "الحادى و الثلاثين", _ "الثانى و الثلاثين", "الثالث و الثلاثين", "الرابع و الثلاثين", "الخامس و الثلاثين", _ "السادس و الثلاثين", "السابع و الثلاثين", "الثامن و الثلاثين", "التاسع ة الثلاثين", _ "الاربعين", "الحادى و الاربعين", "الثانى و الاربعين", "الثالث و الاربعين", "الرابع و الاربعين", _ "الخامس و الاربعين", "السادس و الاربعين", "السابع و الاربعين", "الثامن و الاربعين", _ "التاسع و الاربعين", "الخمسين") Tp = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _ 21, 22, 23, 24, 35, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, _ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50) For m = LBound(Ar) To UBound(Ar) If Num = m + 1 Then Reslt = Replace(Num, Num, Ar(m)) End If Next TextNums = Reslt End Function

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

استخدم دالة Mod للحصول على فرق الشلنات = Mod(Total, 0.05)

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

تفضل اخي تم تعديل كود الترحيل والتعديل معا ليتناسب مع الاضافات الجديدة Private Sub Modify_data_Click() 'تعديل Set WS = Sheet1 If TextBox1.Text = "" Then MsgBox "برجاء ادخال الرقم" Exit Sub Else Dim x As Long Dim y As Long x = WS.Range("A" & Rows.Count).End(xlUp).Row For y = 2 To x If WS.Cells(y, 1).Value = Me.recherch.Text Or WS.Cells(y, 2).Value = Me.recherch2.Text Then WS.Cells(y, 1).Value = Me.TextBox1.Value WS.Cells(y, 2).Value = Me.TextBox2.Value WS.Cells(y, 3).Value = Me.TextBox3.Value WS.Cells(y, 4).Value = Me.TextBox4.Value WS.Cells(y, 5).Value = Me.TextBox5.Value WS.Cells(y, 6).Value = Me.TextBox6.Value WS.Cells(y, 9).Value = Me.TextBox7.Value WS.Cells(y, 10).Value = Me.TextBox8.Value WS.Cells(y, 11).Value = Me.TextBox9.Value WS.Cells(y, 21).Value = Me.Label11.Caption End If Next y For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" End If Next ctrl Me.recherch.Value = "" Me.Label11.Caption = "" Me.Image1.Picture = LoadPicture(Label11.Caption) Me.ListBox1.Visible = False End If MsgBox "تم تعديل البيانات", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تأكيد" End Sub Private Sub Data_transfer_Click() 'ترحيل Dim sh As Worksheet Dim lr As Long Set sh = Sheet1 'ThisWorkbook.Sheets("نشاط") lr = sh.Range("A" & Rows.Count).End(xlUp).Row If UserForm4.TextBox1.Text = "" Then MsgBox "برجاء ادخال البيانات" Exit Sub End If With sh .Cells(lr + 1, "A").Value = Me.TextBox1.Text .Cells(lr + 1, "B").Value = Me.TextBox2.Text .Cells(lr + 1, "C").Value = Me.TextBox3.Text .Cells(lr + 1, "D").Value = Me.TextBox4.Text .Cells(lr + 1, "E").Value = Me.TextBox5.Text .Cells(lr + 1, "F").Value = Me.TextBox6.Text .Cells(lr + 1, "I").Value = Me.TextBox7.Text .Cells(lr + 1, "J").Value = Me.TextBox8.Text .Cells(lr + 1, "K").Value = Me.TextBox9.Text .Cells(lr + 1, "U").Value = UserForm4.Label11.Caption End With For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" End If Next ctrl Me.recherch = Empty Me.Label11.Caption = Empty Me.Image1.Picture = LoadPicture(Label11.Caption) MsgBox "تم ترحيل البيانات بنجاح ", Exclamation, "محمود الطحاوي" End Sub طلب تعديل يوزيرفورم 5.xlsm

اعتقد تحتاج تنزيل Access Runtime

العفو اخي الكريم بما انني استطعت استعاب المطلوب اليك الكود النهائي للملف ربما اسرع عند انشاء عدد كبير من اوراق العمل Public Sub MH_2() Dim ws As Worksheet, WS1 As Worksheet Dim arr As Variant, MH1 As Variant Dim lngArr As Long, lr As Long Dim MH2 As String Dim rngCell As Range temps = Timer 'باستثناء الاوراق التالية MH2 = "Vehicle,Data,Sample" Set WS1 = Sheet1 lr = WS1.Range("H" & WS1.Rows.Count).End(xlUp).Row arr = WS1.Range("H2:H" & lr).Value Application.ScreenUpdating = False ' اظهار النمودج Sheet2.Visible = True 'حدف اوراق العمل For Each ws In Worksheets If InStr(1, MH2, ws.Name) = 0 Then MH1 = Application.Match(ws.Name, arr, 0) If IsError(MH1) Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If End If Next ws ' نسخ For lngArr = LBound(arr) To UBound(arr) If Len(Trim(arr(lngArr, 1))) > 0 Then If Not Evaluate("ISREF('" & arr(lngArr, 1) & "'!A1)") Then Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = arr(lngArr, 1) ' تسمية اوراق العمل Range("i19").Value = arr(lngArr, 1) '("i19") اضافة اسم ورقة العمل للخلية ' End If End If Next lngArr ' حدف الارتباطات السابقة With Sheet1 .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).ClearContents Set rngCell = .Range("B2") End With 'إنشاء ارتباطات تشعبية على بيانات الاوراق الجديدة For Each ws In ActiveWorkbook.Worksheets If InStr(1, MH2, ws.Name) = 0 Then rngCell.Hyperlinks.Add Anchor:=rngCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name Set rngCell = rngCell.Offset(1) End If Next ws Set rngCell = Nothing Set WS1 = Nothing ' اخفاء النمودج Sheet2.Visible = False Sheet1.Activate Application.ScreenUpdating = True MsgBox "تم انشاء" & " " & Application.Sheets.Count - 3 & " " & "ورقة عمل جديدة " & "-" & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000") & "ثانية", Exclamation, "Officena" End Sub Personal_V2.xlsm

تفضل أخي محاولتي وبالاستعانة بكود أجنبي ووافني بالرد . DDTest114.accdb

1)لم توضخ المطلوب جيدا هل هناك أسماء محددة تريد تغييرها. 2) هل التنفيذ على نطاق معين أو على الشيت بالكل Sub Replace() Dim sheet As Worksheet Dim Réf As Variant Dim val As String Dim y As Long Réf = Array("علي", "محمد", "احمد", "ضياء") val = "موظف" For y = LBound(Réf) To UBound(Réf) For Each sheet In ActiveWorkbook.Worksheets sheet.Columns("A:A").Replace What:=Réf(y), Replacement:=val, _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False Next sheet Next y End Sub لتنفيد الامر على جميع خلايا ورقة العمل يمكنك استبدال هذا الجزء من الكود sheet.Cells.Replace What:=Réf(y), Replacement:=val, _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False Next sheet Next y test.xlsm

جزاك الله خيرا اخي العزيز @أبو عبدالله الحلوانى

السلام عليكم ورحمة الله إذا فرضنا أن السريالات موجودة في العمود B بداية من الخلية B2 فتكون المعادلة في C2 (مثلا) كما يلي: بالفرنسية : =--STXT(B2;TROUVE("/";B2;1)-4;4) وبالإنجليزية : =--MID(B2;FIND("/";B2;1)-4;4) والله أعلم