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

شرف ليا انى اضيف موضوع وسط اساتذتى https://www.mediafire.com/file/pzr38qxqwg4e2a2/Ferry_Login_v1-_free.accdb/file Ferry Login v1free.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة لأنشاء الجداول بطريقة مختلفة عن الطريقة التقليدية التي نعرفها .. إلا أنها ما زالت قيد التطوير الفكرة تعتمد على نموذج واحد فقط يمكّن المستخدم من إنشاء جداوله والحقول التي تحتويها ونوع الحقول بشكل سهل وبسيط . أولاً انقر على الزر " أنشاء حقل جديد ... " ثانياً قم بملئ الحقول ( اسم الجدول ، اسم الحقل ، نوع الحقل ) ، عند اختيار نوع الحقل سيتم إضافة الحقل الجديد الى الـ List Box تسلسلاً حسب الإدخال . عند الإنتهاء من إدخال جميع الحقول وأنواعها ، انقر الزر " إنشاء الجدول ... " ، وهنا سيتظهر رسالة تفيد بأنه ( لابد من وجود حقل مفتاح أساسي ، هل ترغب بتعيين حقل مفتاح أساسي ؟ ) عند اختيار Yes - نعم سيتم تعيين أول حقل كمفتاح أساسي ؛ وإذا تم اختيار No - لا سيتم انشاء الجدول دون مفتاح أساسي . عند إنشاء الجدول سيتم تصحيح عدة نقاط بشكل تلقائي وهي :- إزالة المسافة من اسماء الجداول واستبدالها بـ " _ " . إضافة الجزء "_Tbl" الى اسم الجدول عند انشائه . أيضاً إزالة المسافة من أسماء الحقول واستبدالها بـ " _ " . الملف مفتوح المصدر TBL Maker.accdb بناءً على إقتراحات أستاذي وصديقي @Moosak ، والتعديلات التي تقدم بها صديقي وأستاذي @ابو جودي ، تم دمج وإضافة تعديلات جديدة أرجو أن تنال رضاكم وإعجابكم . تم إضافة ميزة أن يكون في الجدول أكثر من حقل مفتاح أساسي . تم إضافة ميزة التعديل على الحقول أو حذف أحد الحقول قبل إنشاء الجدول من خلال زر " تعديل الحقول " ، وبعد إجراء التعديلات انقر زر " تأكيد التعديل ". تم دمج ميزة حرية إضافة " _Tbl " الى اسم الجدول عند انشائه ( فكرة الأستاذ أبو جودي مع إجراء تعديل بسيط ) - إختياري . تم دمج ميزة أن يكون أسماء الجداول والحقول ( الإنجليزية ) تبدأ بحرف كبير Capital Letter . تم إضافة ميزة فتح الجدول بعد انشائه لرؤية النتيجة أو لإدخال البيانات - إختياري . تم إضافة زر " مفتاح أساسي " لتمكين المستخدم من اختيار الحقول التي يريدها أن تكون مفتاح أساسي . تم إضافة زر " إضافة حقل " لإضافة حقل جديد . تم تعديل التصميم بشكل بسيط ليتناسب مع محتوياته والميزات الجديدة . ✔ لا حاجة لأي مكتبات أو مديولات عند نسخ النموذج لمشروعك والبدء بالإستفادة من ميزاته . ✔ أتطلع لأي أفكار جديدة أو اقتراحات TBL Maker.accdb680 kB · 7 downloads تم تعديل منذ 7 ساعات بواسطه Foksh

بناءً على إقتراح أستاذنا @Moosak تم إضافة ميزة " التسمية التوضيحية - Caption " للحقول . تم إضافة ميزة " التعرف على حقل الترقيم التلقائي " عند وجوده والتخيير بين جعله مفتاح أساسي أو لا . في حال عدم وجود حقل ترقيم تلقائي ، سيتم التنبيه بعدم وجوده وإنشاء حقل جديد ID = AutoNumber ؛ والتخيير أيضاً بإنشائه أو لا . وعند إنشائه سيكون له خاصية مفتاح اساسي PrimaryKey . 💡ملاحظة : في التعديل القادم سيتم إتاحة الفرصة للمستخدم بالتعديل على الحقول قبل إنشاء الجدول كخطوة أخيرة 🤗 TBL Maker.accdb

Gemini API.accdb

اولا شكرا على الهدية ثانيا اسمح لي بإضافة الملف في الموضوع بعد الضغط والاصلاح للملف من خلال الاكسس ... لان ملف الميديا يمكن حذفه بعد فترة من الزمن وسوف يخسر المنتدى هذه الهدية القيمة ..... Ferry Login v1free.accdb

السلام عليكم اعتذر جدا جدا جدا لكم اساتذتى الافاضل @Moosak , @عمر ضاحى اثناء تجربتى للتعديلات لم اقم الا باضافة حقل واحد لضيق وقتى لذلك لم تظهر المشكلة والان بفضل الله تم تدارك المشاكل وحلها جميعا يرجى الرد بنتيجة التجربة وانتظروا تحديث جديد ان قدر الله لنا اللقاء ان شاء الله Create advanced tables V 2.0.1 .accdb

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

اعرض الملف استبدال أسماء كل الملفات فى مجلد بحثت عنه ولم اجده ـ على الرغم اني اذكر اضافته سابقا فاضيفه الان لمن يحتاج مثل هذا الكود 1- استخدم الكود السابق نشره لتوثيق كافة اسماء الملفات فى مجلد مكتبة الموقع - تطبيق لتوثيق قائمة بالمجلدات و الملفات و خصائصها - مفيد جداً او كتب اسماء الملفات الحالية الموجودة فى المجلد المستهدف مباشرة فى العمود B 2 - ثم اكتب فى العمود D اسماء الملفات الجديدة 3- شغل الكود لاستبدال اسماء الملفات ، و اختار المجلد المستهدف Sub RenameMultipleFiles() ' add old file name to column B , and new File name to Col D With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If .Show = -1 Then selectDirectory = .SelectedItems(1) dFileList = Dir(selectDirectory & Application.PathSeparator & "*") Do Until dFileList = "" curRow = 0 On Error Resume Next 'read old file name from column B curRow = Application.Match(dFileList, Range("B:B"), 0) If curRow > 0 Then 'cganeg to new file name from column D Name selectDirectory & Application.PathSeparator & dFileList As _ selectDirectory & Application.PathSeparator & Cells(curRow, "D").Value End If dFileList = Dir Loop End If End With End Sub صاحب الملف محمد طاهر عرفه تمت الاضافه 06 يول, 2024 الاقسام قسم الإكسيل  

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("Sheet1") End Property Sub Sort_Category() Dim OneRng As Range Dim lr As Long lr = F.Cells(Rows.Count, "E").End(xlUp).Row Set OneRng = F.Range("A2:L" & lr) With OneRng .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo End With End Sub '***************************** Sub Filter_and_create_Sheets() Application.DisplayAlerts = False Application.ScreenUpdating = False F.[w1] = F.[E1] RngA = F.[A1].CurrentRegion.Rows.Count RngB = F.[A1].CurrentRegion.Columns.Count F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=F.[w1], Unique:=True For Each c In F.Range("W2:W" & F.[W65000].End(xlUp).Row) F.[W2] = c.Value On Error Resume Next Sheets(CStr(c.Value)).Delete On Error GoTo 0 Sheets.Add After:=Sheets(Sheets.Count) Set n = ActiveSheet n.Name = CStr(c.Value) n.DisplayRightToLeft = True F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=F.[W1:W2], CopyToRange:=[A1] For r = 1 To 12 n.Cells.EntireRow.AutoFit n.Columns(r).ColumnWidth = F.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Next c F.Activate End Sub تقرير صف أول 2025.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة مختلفة Sub CopyRow_Item() Dim i&, j&, n&, cnt&, r&, lr&, a As Boolean Dim arr() As Variant, rCrit As Variant, rng As Variant Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("قاعدة العملاء") cnt = 2 With WS If [N1] = Empty Then MsgBox "اصحى و اكتب التاريخ", vbExclamation: Exit Sub Application.ScreenUpdating = False lr = .Columns("b:k").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row a = True n = 0 rng = .Range("B2:K" & .Range("B" & Rows.Count).End(xlUp).Row).Value cnt = .Cells(.Rows.Count, "AM").End(xlUp).Row ReDim arr(1 To UBound(rng), 1 To UBound(rng, 2)) For i = 1 To UBound(rng) If rng(i, 6) <> "" Or rng(i, 7) <> "" Then a = False n = n + 1 For j = 1 To UBound(rng, 2) arr(n, j) = rng(i, j) Next j End If Next i If n > 0 Then .Range("AM" & cnt + 1).Resize(n, UBound(arr, 2)) = arr cnt = cnt + n For r = 2 To lr Union(.Range("F" & r).Resize(, 2), .Range("I" & r)).ClearContents Next r Application.Goto .Range("AM" & 2), True: [N1] = "" End If End With Application.ScreenUpdating = True If a Then MsgBox "الرجاء إظافـــة التحصيلات", vbExclamation Else MsgBox "الحمد لله - تم ترحيل التحصيلات بنجاح " & vbNewLine & _ " مستر إيهاب الاسوانى", 64 End If End Sub كود ترحيل V3.xlsm

اذا كنت قد فهمت طلبك بشكل صحيح فالتعديل التالي سوف يوفي بالغرض Option Compare Text Dim a, i As Long Dim OneRng(), Rng, rCrit1, rCrit2 Dim d As Object, ComboAry As Variant Private Const Cpt As String = "Compte magasin" Private Const tbl As String = "Table1" Dim Crit(), headers(), choix(), colClé, Cnt, Item_Code Private Sub UserForm_Initialize() Dim Irow& Set f = Sheets(Cpt) a = Sheets(Cpt).ListObjects("Table1").DataBodyRange.Columns("A:X") Set d = CreateObject("scripting.dictionary") d.CompareMode = vbTextCompare Irow = f.Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row Set Cnt = f.Range("G2:N" & Irow): Crit = Cnt.value headers = Application.Index(Cnt.Offset(-1).value, 1) Me.ComboBox10.List = Application.Transpose(f.Range("J1:N1").value) ComboAry = Array("ComboBox1", "ComboBox3", "ComboBox5", _ "ComboBox9", "ComboBox10", "ComboBox13", "ComboBox12") For i = 0 To UBound(ComboAry): Me.Controls(ComboAry(i)).value = "*": Next i '''''''' Code..... ''''''''''''''''''''' End Sub ******************************************************************** Private Sub ComboBox10_Change() Item_Code = Val(Me.ComboBox12): Prices = Me.ComboBox10 If IsNumeric(Me.ComboBox10) Then _ tmp = Val(Me.ComboBox10) Else tmp = Prices colClé = Application.Match(tmp, headers, 0) For i = LBound(Crit) To UBound(Crit) If UCase(Crit(i, 1)) = UCase(Item_Code) And _ Prices <> "*" Then Me.TextBox7.value = Crit(i, colClé) Next i End Sub بيانات فاتورة 3.xlsm

سأكشف لكم عن سر 👀 كنت قد بدأت منذ عدة أيام بإنشاء طريقة تساعد على عمل قوائم مختصرة للنماذج ، ولكنها أخذت مني وقتاً وجهداً كبيرين ، وتوقفت عند مرحلة إعادة تجميع الأفكار 😇 💡 قريباً النسخة الأولى 💡

تم إصلاح بعض الأخطاء البرمجية ( تحسين أداء ) ، وإضافة ميزة التعرف على لغة أوفيس ( عربي - إنجليزي ) فقط . بحيث :- يتم التعرف على اللغة في واجهة أوفيس للمستخدم بحيث تظهر أسماء أنواع الحقول باللغة الإنجليزية إذا كان إصدار أوفيس باللغة الإنجليزية ، وخلاف ذلك تظهر القائمة المنسدلة لأنواع الحقول باللغة العربية . TBL Maker.accdb

السلام عليكم تفضل الحل بالأكواد تضع كافة الملفات في مجلد (فولدر واحد) وتضع معهم هذا الملف suppliers.xlsm المرفق تفتخه وتضغط الزر ، يبدأ في عمل التالي فتح الملفات الواحد تلو الأخر استدعاء البيانات من الملف المفتوخ ونسخها للملف الأصلي غلق الملف المفتوخ ثم تكرار الخطوات الثلاثة ختي نهاية الملفات في الفولدر مهما كان عدد الملفات suppliers.xlsm

شوف هذا راى ولك طبعا مطلق الحرية انا عن نفسى افضل استخدام اسماء الجدول بالطريقة الاتية tblOfficenaForms ممكن حد تانى يحبها كده tbl_Officena_Forms انا وضعت دالة لتحويل اول حرف من كل مفطع الى حرف كبير وباقى الاحرف صغيرة وترطت للمستخدم حرية الاختيار فى موضوع ال Under Score وطبعا انا اسف انا غلط فى كتابتها على النموذج بالشكل Use ChkUnder Score لانها مفروض كانت تكون Use Under Score و\بعا جمبها او تحتها تلميح لتوضيح الوظيفة بس وقتها كنت خلاص رايح الشغل وضيق وقتى خلانى اقع فى المشكلة الالولى اللى اظهرت الرسائل مع اكثر من حقل طبعا انا اول التعديل كتبت الكود بصراحة ان تكون النتيجة بالشكل التالى tblOfficenaForms وبعدين فلت ليه افرض رأى فى الكود ولذلك فكرت فى استخدام Optional علشان اسيب للجميع حرية الاختيار وعدلت الكود تانى على هذا الاساس لاحظ كده فى الفترى الاخيرة تحديدا كل ما اقدمه احاول بقدر الامكان تحقيقة باكبر قدر ممكن من المرونه حتى وان تطلب هذا جهدا فى التفكير وانشاء وترتيب الافكار فى الكود وان ذادت اسطر الكود لا ابالى شوفت مرفق لعبة الكلمات المتقاطعة ؟ من هنا كنت عاملة بسيط من زمان جدا جدا على سبيل التسلية وقتها ولم اكمل العمل ولكن بعد مشاهدتى لموضوع الاستاذ @Moosak صحى الطفل اللى جوايا وذكريات الماضى لانه كنت و والدى رحمه الله تعال وكل المسلمين يوميا نلعبها فى الجرائد ونلعب ونضخك وقت الافطار بعد صلاة الفجر و وقت الشروق ولكن بصراحة لانه احبه جدا فى لله قلت اعاكسة ويلا بقى تحدى.... طبعا امزح انه اخى الحبيب ولكن انا تعلمت الكثر بسبب فقط عاصفة الافكار التى اجتاحتنى وقتها

حيلك حيلك يا عم انت رايح فين هههه فرمل و وقف وخد نفس ؛ إنت ما صدقت يا سيد بمزح والله يا محمد مش قصدي كل اللي خطر في بالك مش قلتلك من زمان ما نكشتكش وهزرت معاك هههههههههه

انت اي حاجه بتعملها بتبقي جامده يا بروف 😉 😉 ولا اقولك يا MPV بروف ☺️ ☺️ انت مش فنان انت دائما مبدع لو عملت نموذج فاضي حتي هيكون اختراع 🙄🙄 انا مش بحسد انا بقر بس 🤣🤣

السلام عليكم تفضل المرفق التكرار.xlsx

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

السلام عليكم و رحمة الله استخدم هذا الكود Sub AddRow() Selection.EntireRow.Insert , xlFormatFromLeftOrAbove End Sub

بالنسبة للتسلسل يمكنك استخدام الصيغة التالية مع سحبها للاسفل بعد حدف كود ترقيم الصفوف من حدث ورقة 1 =IF(C9>0,SUBTOTAL(3,$C$9:C9),"") اما بخصوص تنسيق اعمدة الروابط اظن انه من الافضل ربط الكود مع زر يمكنك استخدامه مثلا بعد الانتهاء من نسخ جميع الروابط على العمودين جرب هدا Function tmp(Cnt As String) As Boolean Dim Request As Object Dim rc As Variant On Error GoTo EndNow Set Request = CreateObject("WinHttp.WinHttpRequest.5.1") With Request .Open "GET", Cnt, False .Send rc = .StatusText End With Set Request = Nothing If rc = "OK" Then tmp = True Exit Function EndNow: End Function Sub add_Hyperlinks() Application.ScreenUpdating = False Set WS = Sheets("Sheet1") Dim c As Excel.Range, Cnt As String, r As Excel.Range Dim a As Range, b As Range, Rng As Range lr = WS.Columns("i:j").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = WS.Range("i9:i" & lr): Set b = WS.Range("j9:j" & lr): Set Rng = Union(a, b) For Each c In a If c > "" Then c.Select Debug.Print c.Value Cnt = Trim(CStr(c.Text)) If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=c, Address:=Cnt, TextToDisplay:="رابط اليوتيوب" End If Next c For Each r In b If r > "" Then r.Select Debug.Print r.Value Cnt = Trim(CStr(r.Text)) If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=r, Address:=Cnt, TextToDisplay:="رابط الفيسبوك" End If Next r With Rng .Font.Color = RGB(0, 0, 255) .Font.Underline = xlUnderlineStyleNone .Font.Bold = True .Font.Name = "Calibri" .Font.Size = 16 End With Application.ScreenUpdating = True End Sub 14-7-2024 V2.xlsm

الاكسيس والموبايل استحالة التوافق بينهما مهما حاولت فلا تتعب نفسك ابحث عن لغة اخرى

اسف انا لسه واخد بالى انه سؤال يشبه التحدى انا قولت دعوة للتطوير ويل مع بعض نطوره واتعلم منكم اكتر lمرفق تعديل للتنسيق اعتقد ظبط شوية ونطوره برضه مع بعض Gemini API.rar

انا لم اجرب بعد 2 اقترح اضافة صندوق نص و كود استبدال نجمة "*" بسطر جديد يسحب النص الى نص بسطر جديد للتنسيق

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

الله ينور عليك يا عبقرينو 😊😊 مش بقولك بتذاكر من ورانا

وعليكم السلام ورحمة الله تعالى وبركاته اولا اشكرك استاد فوزي على هده الكلمات الطيبة هدا شرف وفخر انوله منك ووفقنا الله واياكم لما يحب ويرضى تفضل اخي جرب هدا Option Explicit Sub Delete_tables() Dim ws As Worksheet Dim i As Long, lr As Long, r As Range, j As Long Set ws = Worksheets("كشف الطباعة") Application.ScreenUpdating = False Set r = [H1] With ws lr = .Cells(.Rows.Count, "a").End(xlUp).Row j = r * 35 For i = j To lr If Range("a" & i) > j Then .Range(ws.Cells(j, "A"), .Cells(lr, "E")).Clear End If Next i End With Application.ScreenUpdating = True End Sub حذف الجداول v2.xlsm

وعليكم السلام 🙂 الفرز يجب ان يكون عن طريق حقل المعرف. الاستعلام: . والدالة في الوحدة النمطية: Function Concat(PR As Double) Dim rst As Recordset Dim i As Long, RC As Long Set rst = CurrentDb.OpenRecordset("select [Category] From PRindex Where [PuReq]=" & PR & " Order by [المعرف]") rst.MoveLast: rst.MoveFirst: RC = rst.RecordCount For i = 1 To RC Concat = Concat & "," & rst!Category rst.MoveNext Next i Concat = Mid(Concat, 2) rst.Close: Set rst = Nothing End Function . والنتيجة: 1617.PRindex.accdb.zip

السلام عليكم ورحمة الله أخي الفاضل (موسى) اسمح لي بشرح الفكرة نيابة عن أخي الخبير (ابو خليل) كان طلبي هو أن يتم طباعة كلمة (مستجد) و (دمج) و (قرار) بنفس هذا الترتيب ولكن الاكسس يقوم بترتيبهم ابجديا فيقوم بطباعة دمج أولا ثم دمج ثم قرار وللتحايل على هذا الأمر قام أخي (ابو خليل) بعمل جدول وقام بإسناد رقم ID للكلمات الثلاث بالترتيب (مستجد) 1 (دمج) 2 (قرار) 3 ثم قام بعمل استعلام داخل property sheet في قسم Row Source ليقوم التقرير بعرضهم بالترتيب حسب رقم ID متجاوزا بذلك الترتيب الأبجدي للأكسس ثم يقوم مربع النص المسمى (الحالة) في التقرير بأخذ النص أو الكلمات (مستجد) و (دمج) و (قرار) بترتيب ID ثم يقوم التقرير بتكرار الكلمات الثلاث في كل صفحاته لأن مربع النص المسمى (الحالة) موضوع في (الحالة Hader) وأي نص يوضع في شريط مكتوب عليه (Hader) أو رأس في التقرير سيقوم التقرير بتكراره في كل الصفحات. كيف يعرف التقرير أين يضع الكلمات (مستجد) و (دمج) و (قرار)؟ يتم ذلك عن طريق من حقل الحالة في الجدول المسمى (الرقمية) حيث يقوم التقرير بعمل مجموعة وفرز عل الجدول ليضع كل حالة أمام الكلمات (مستجد) و (دمج) و (قرار) الخاصة بها. أرجو أن أكون قد أوضحت قدر الإمكان وشكراً لكم جميعاً.

اليك طريقة متبعة غالبا عند تصميم قواعد البيانات 3.rar

اتفضل هذا المطلوب 2.rar

شكراً لك أخي الحبيب @ahmed draz على لطفك وكلماتك الطيبة .. المنتدى عامر بالمحبة الموصولة بين أعضائه 🥰 . ونتمنى أن نكون عند حسن الظن 💐

وعليكم السلام ورحمة الله وبركاته أكواد VBA لا تعمل على الجوال لأن الجوال لا يدعم تشغيل برامج Excel التي تحتوي على VBA

يمكنك وضع الكود التالي في Private Sub Workbook_Open Private Sub Workbook_Open() ' هنا اسماء الاجهزة المسموح للمصنف الاشتغال عليها If Environ("computername") <> "CFAMURAD" And Environ("computername") <> "Officena" Then 'عند عدم تحقق الشرط يتم اظهار الرسالة وغلق الملف Application.DisplayAlerts = False MsgBox " لا يمكنك تشغيل هدا المصنف على هدا الكمبيوتر " & _ vbLf & vbLf & " .......... المرجوا الاتصال", _ vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, "معلومات" ThisWorkbook.Close Application.DisplayAlerts = True End If End Sub يستحسن وضع باسوورد لمحرر الاكواد لكي لا يتم التلاعب بالملف فتح المصنف على اجهزة محددة.rar

تعديل مرفق استاذ @Foksh 😇 1- ان شاء كود لكافة عناصر الفورم فقط اختيار النموذج 2- يفتح حدث الفورم فقط لصق ctrl +V ملاحظة فقط اضافة حدث عند الفتح حتى لو كان فارغ admin.rar

Sub RemoveChars() Dim lr&, Cel As Range, A As String, r As Range lr = Cells(Rows.Count, "b").End(xlUp).Row Application.ScreenUpdating = False Set r = Range("b2:b" & lr) For Each Cel In r A = Replace(Cel.Value, ",", " ") Cel.Value = A Next Cel Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته تفضل =SUBSTITUTE(B2;",";" ")

ما الغرض من فك حماية جميع اوراق العمل لتقوم بافراغ الخلايا المحددة على ورقة عمل واحدة جرب هدا Sub Protect() Dim x As Worksheet Set x = ActiveSheet Application.ScreenUpdating = False x.Unprotect "bac20022002" With Selection .ClearContents End With x.Protect "bac20022002" Application.ScreenUpdating = True End Sub

بطريقة اخرى Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("12 د بنون") End Property Public Property Get lr() As Long: lr = F.Columns("C:J").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row End Property Sub Sort_Names() 'ترتيب ابجدي Dim OneRng As Range Set OneRng = F.Range("C11:J" & lr) With OneRng .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo End With End Sub '*********** Sub Sort_TOTAL() 'ترتيب تنازلي Dim OneRng As Range Set OneRng = F.Range("C11:J" & lr) With OneRng .Sort Key1:=.Columns(7), Order1:=xlDescending, Header:=xlNo End With End Sub '********* Sub Sort_TOTAL2() 'ترتيب تصاعدي Dim OneRng As Range Set OneRng = F.Range("C11:J" & lr) With OneRng .Sort Key1:=.Columns(7), Order1:=xlAscending, Header:=xlNo End With End Sub فرز Final.xlsb

تفضل اخي @محمد زيدان2024 تم تعديل الاكواد لتتناسب مع طلبك Option Compare Text Public Property Get f() As Worksheet: Set f = Worksheets("12 د بنون") End Property '================29/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Sub TriTotal_Descending_Order() 'ترتيب تنازلي Dim a() Dim r As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row) ' تحديد نطاق معين 'a = [C11:J38].Value: Set r = [C11:J38] ' <<=======عمود المجموع======== Call Quick(a(), LBound(a), _ UBound(a), 7, False): r.Value2 = a End Sub '**********فرز سريع************* Sub Quick(a(), gauc, droi, Cnt, ordre) Total = a((gauc + droi) \ 2, Cnt) Rng = gauc: d = droi Do If ordre Then Do While a(Rng, Cnt) < Total: Rng = Rng + 1: Loop Do While Total < a(d, Cnt): d = d - 1: Loop Else Do While a(Rng, Cnt) > Total: Rng = Rng + 1: Loop Do While Total > a(d, Cnt): d = d - 1: Loop End If If Rng <= d Then For i = LBound(a, 2) To UBound(a, 2) temp = a(Rng, i): a(Rng, i) = a(d, i): a(d, i) = temp Next i Rng = Rng + 1: d = d - 1 End If Loop While Rng <= d If Rng < droi Then Call Quick(a, Rng, droi, Cnt, ordre) If gauc < d Then Call Quick(a, gauc, d, Cnt, ordre) End Sub '************************************ Sub Tri_Colmun_Name() 'ترتيب ابجدي Dim clé() As String, index() As Long, Rng As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Dim b(): Set Rng = f.[C11] ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2)) Set rCrit = CreateObject("System.Collections.Sortedlist") For i = LBound(a) To UBound(a) rCrit.Add a(i, 1) & i, i Next i For tmp = LBound(a) To UBound(a) For arr = LBound(a, 2) To UBound(a, 2) b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr) Next arr Next tmp Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b End Sub '************************************* Sub Tri_Total_Colmun() 'ترتيب تصاعدي Dim clé() As String, index() As Long, Rng As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Dim b(): Set Rng = f.[C11] ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2)) Set rCrit = CreateObject("System.Collections.Sortedlist") For i = LBound(a) To UBound(a) rCrit.Add a(i, 7) & i, i Next i For tmp = LBound(a) To UBound(a) For arr = LBound(a, 2) To UBound(a, 2) b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr) Next arr Next tmp Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b End Sub فرز V3.xlsb

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

تم إضافة الملف للمشاركة الأصلية 🙂

تم التعديل على النحو التالي : اعداد التقرير فيما لو تم نقل البرنامج الى مدرسة اخرى 1- حذف جدول يوزر من الاستعلام 2- جلب بيانات جدول يوزر الى التقرير بالكود والتي تمثل : اسم المديرية / واسم المدرسة / والفترة ... بدلا من كتابتها ثابتة داخل التقرير 3- تعديل بعض الاسماء .. مثلا اسم المديرية = mod وهذا الاسم محجوز في اكسس 4- تم تعديل مصدر البيانات في مربعي التحرير في النموذج من بيانات ثابتة جامدة الى بيانات متغيرة مرنة يتم جلبها من الجدول ملحوظة : ستجد الترتيب في مربع تحرير الصف غير منسق ولكنه حقيقة منسق حسب الحروف العربية .. والصح ان يكون معرف الصف في الجدول رقما وليس نصا Database5.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته اعتقد اخي الفاضل ان انسب طريقة لدالك هي استخراج القيم التي يساوي مجموعها القيمة المدخلة في عمود مغاير لان الاعتماد على التظليل ممكن يسبب لك تداخل في النتائج المتوقعة عند تواجد نفس الرقم في اكثر من احتمال مثال لو اردنا استخراج الاعداد الخاصة ب 34 مع وجود الارقام التي قمت بدكرها في مشاركتك سنعثر على نفس الارقام مكررة في اكثر من احتمال 👇 لتتفادى هدا ممكن استخدام الدالة التالية مثال لعملية استخراج القيم المتوقعة 👈 لنفترض ان الخلية المخصصة لادخال المجموع هي B2 In cell B2 =IFERROR(TRANSPOSE(xFormula(A2:A11; B2));"") وفي Module انسخ الكود التالي مع حفظ الملف بصيغة الماكرو Option Explicit '================29/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Public Function xFormula(rngNumbers As Range, XSum As Long) Dim arNumbers() As Long, tmp() As Long, arr() As String, F As Range, Cnt As Long ReDim arr(0) If rngNumbers.Count > 1 Then ReDim arNumbers(rngNumbers.Count - 1) Cnt = 0 For Each F In rngNumbers arNumbers(Cnt) = CLng(F.Value) Cnt = Cnt + 1 Next F Call Cpt(arNumbers, XSum, tmp(), arr()) End If ReDim Preserve arr(0 To UBound(arr) - 1) xFormula = arr End Function Private Sub Cpt(Numbers() As Long, target As Long, tmp() As Long, ByRef arr() As String) Dim s As Long, i As Long, j As Long, num As Long Dim Rng() As Long, tmpRec() As Long, n As Long s = a(tmp) If s = target Then n = UBound(arr) ReDim Preserve arr(0 To n + 1) arr(n) = b(tmp) End If If s > target Then Exit Sub If (Not Not Numbers) <> 0 Then For i = 0 To UBound(Numbers) Erase Rng() num = Numbers(i) For j = i + 1 To UBound(Numbers) Total Rng, Numbers(j) Next j Erase tmpRec() C tmpRec, tmp Total tmpRec, num Cpt Rng, target, tmpRec, arr Next i End If End Sub Private Function b(x() As Long) As String Dim n As Long, result As String result = " " & x(n) For n = LBound(x) + 1 To UBound(x) result = result & "-" & x(n) Next n result = result & " " b = result End Function Private Function a(x() As Long) As Long Dim n As Long a = 0 If (Not Not x) <> 0 Then For n = LBound(x) To UBound(x) a = a + x(n) Next n End If End Function Private Sub Total(arr() As Long, x As Long) If (Not Not arr) <> 0 Then ReDim Preserve arr(0 To UBound(arr) + 1) Else ReDim Preserve arr(0 To 0) End If arr(UBound(arr)) = x End Sub Private Sub C(destination() As Long, source() As Long) Dim n As Long If (Not Not source) <> 0 Then For n = 0 To UBound(source) Total destination, source(n) Next n End If End Sub ادا كنت تستخدم النسخ الحديثة من الاوفيس ضع المعادلة التالية في الخلية E2 للتحقق من مجموع القيم المستخرجة مع سحبها للاسفل =IF(D2<>"";SUM(FILTERXML("<x><y>"&SUBSTITUTE(TRIM(CONCAT(IFERROR(0+MID(D2;SEQUENCE(LEN(D2));1);" ")));" ";"</y><y>")&"</y></x>";"//y"));"") فحص مجموعة قيم لايجاد اى منها يساوى قيمة معينة.xlsm

أخي @Zooro1 أنت لم توجه سؤالك لشخص معين ولا ندري أي نموذج اعتمدت في برنامجك !! 🙂 وكذلك لم تضع ملف مرفق لنعرف ماذا فعلت بالضبط !! لذلك لم تجد من يجيبك على سؤالك 🙂

حاولت البحث عن عبارة حي الشرطة لم اجدها في عمود القرية هل هده اللغة السندية

اخي الفاضل بما انك تريد شكل القوائم متتابعة و مترابطة لابد من اختيار القيم المرغوب تعبئتها على القوائم بطريقة هي الاخرى متتابعة لا يمكنك الاعتماد على الفراغات داخل المعادلة ولا اعتقد انه هناك معادلة من شانها فعل دالك بالطريقة المطلوبة على حسب علمي المتواضع لا اعلم عن طريقة اشتغالك على الملف ولا الهدف من وراء انشاء هده القوائم لاكن مجرد فكرة من شانها مساعدتك اظن ان استخدام الاكواد من الممكن ان يساعدك في هدا ويمكنك نوعا ما من تجاهل الفراغات داخل القوائم واعتبارها قيمة بحث بمعنى ادخال قيمة الصف الاول ولتكن (دهوك) على القائمة الاولى واختيار قيمة فارغة في القائمة 2 و 3 مثلا للحصول على على قيمة الصف الرابع التي يقابلها شرط دهوك في الصف 1 والفراغات في الصف 2 و3 وهكدا مع القوائم الخمس . واخيرا ترحيل القيم المختارة للجدول الثاني اسفل بعضها ادا لم يكن عندك مانع لاستخدامها يكفي انشاء يوزرفورم صغير على الملف يتضمن 5 Combobox وزر وسوف احاول كتابة الاكواد الخاصة بدالك للتجربة

ألف لا بأس عليك يا بروف 🌹🌷 ( شكله الأستاذ محمد عداني 😅 ) أسأل الله العظيم رب العرش العظيم أن يشفيك من كل داء ويعافيك من كل بلاء 🙂🤲🏻

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub CommandButton1_Click() Sum = Evaluate("=SUMIFS(F3:F100000,B3:B100000,"">=""&I2,B3:B100000,""<=""&j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End Sub sumif.xlsm