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

حيث لا يوجد تجاوب من منشيء المشاركة على أسئلة الأعضاء فإن المشاركة لا تستحق التثبيت، وسوف أقوم بإنزالها.

رائع رائع رائع هو المطلوب بالضبط بارك الله في صحتك انت ومن تحب

وعليكم السلام ورحمة الله تعالى وبركاته بما انك لم تقم باظافة اليوزرفورم تمت اظافته من المشاركة السابقة لك والاشتغال عليه بنفس الفكرة ربما هدا ما تقصده Dim depart, Cnt, comment Private Sub UserForm_Initialize() comment = " تحديد ورقة العمل" Me.Label1.Width = 900 depart = Me.Label1.Left Message = " برنامج المخازن يرحب بكم . صل على محمد" Me.Label1.Caption = "**********" & Message & "**********" & Message & "************" Cnt = Len(Me.Label1.Caption): Me.ComboBox1 = comment End Sub '**************************** Private Sub UserForm_Activate() Me.Label1.Visible = True For x = depart To -(2.8 * Cnt - depart) Step -1 Me.Label1.Left = x w = 0.04 temp = Timer Do While Timer < temp + w DoEvents Loop Next x UserForm_Activate End Sub '*********************** Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) Set dico = CreateObject("Scripting.Dictionary") For Each c In ActiveWorkbook.Sheets dico(c.Name) = "" Next c dico.Remove (ActiveSheet.Name) Me.ComboBox1.List = dico.keys Me.ComboBox1.SetFocus End Sub '*********** Private Sub ComboBox1_Change() On Error Resume Next Sheets(CStr(ComboBox1)).Activate Me.ComboBox1 = comment End Sub يوزر فورم.xlsb

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اخي Option Explicit Sub Search_Transfer() Dim WS As Worksheet, cel As Range, lr As Long, Temp(), I As Long, J As Long, X Set WS = ThisWorkbook.Worksheets("Sheet2") lr = WS.Cells(Rows.Count, "R").End(xlUp).Row For Each cel In WS.Range("R5:R" & lr) If cel <> "" Then X = Application.Match(cel, WS.Columns(13), 0) If Not IsError(X) Then I = I + 1 ReDim Preserve Temp(1 To 15, 1 To I) Temp(1, I) = I For J = 2 To 15 Temp(J, I) = WS.Cells(X, J).Value Next J End If End If Next cel Temp = Application.Transpose(Temp) If I > 0 Then WS.Range("V5").Resize(I, UBound(Temp, 2)).Value2 = Temp End Sub

السلام عليكم ورحمه الله وبركاته وبها نبدأ جرب هذا لعله طلبك Option Explicit Sub Sort4() Dim Ws As Worksheet Set Ws = ThisWorkbook.Worksheets("Sheet1") With Ws .Sort.SortFields.Clear .Sort.SortFields.Add Key:=.Range("E10:E13"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .Sort.SortFields.Add Key:=.Range("F10:F13"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .Sort.SortFields.Add Key:=.Range("G10:G13"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal .Sort.SortFields.Add Key:=.Range("H10:H13"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange Ws.Range("E9:H13") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With End Sub

في فكرة تانية جت فدماغي دلوقتي ان شاء الله الفكرة دي هتضمنلك نتيجة 100% بإذن الله 1- عايزين نحذف ما قبل اسم الكتاب وما بعد الرقم 2- الجزء المتبقي معانا هيبقي فيه احتمالين - ان يكون في اسم كتاب تاني - او مفيهوش وفالحالة دي احنا ناخد اللي مافيهوش اسم كتاب تاني وده هشان نحل مشكلة الارقام اللي بتيجي فمواضع متاخرة يبقي احنا دلوقتي هنروح نضيف اسماء الكتب في كولكشين ونمنع التقرار وبعدين نعمل لوب كولكشين دي جوة نتيجة البحث اذ كان في حاجه فيهم موجودة بين اسم الكتاب والرقم معنا كدا ان الرقم ده خاص بالكتاب اللي موجود في الكولكشين فنستبعد النتيجة دي إن شاء الله هتظبط وهتدعيلي

بعد مراجعة هذا الجزء مرة أخرى هذا يمكن الوصل اليه إن شاء الله أثناء عملية البحث ولكني اريد معرفة الاحتمالات التي قد نوجهها حتي نحاول إن شاء الله ان نصل الي تصور مناسب لان كما فهمت أيداً ان عنصر الوقت مهم علي سبيل المثال يمكن استخدام وظيفة كهذه لتقطيع النص Public Function cutString(ByVal fullText As String, _ ByVal cutBy As String, _ Optional ByVal lrSide As String = "leftSide") As String On Error GoTo ErrorHandler If fullText = "" Then 'Debug.Print "Error: fullText is empty" cutString = "" Exit Function End If If cutBy = "" Then 'Debug.Print "Error: cutBy is empty" cutString = fullText Exit Function End If If Len(cutBy) > Len(fullText) Then 'Debug.Print "Error: cutBy is longer than fullText" cutString = fullText Exit Function End If Select Case LCase(lrSide) Case "leftside", "rightside" Case Else 'Debug.Print "Warning: Invalid lrSide value '" & lrSide & "'. Using default 'leftSide'." lrSide = "leftSide" End Select Dim position As Long position = InStr(1, fullText, cutBy, vbTextCompare) If position > 0 Then Select Case LCase(lrSide) Case "leftside" cutString = Mid(fullText, position) 'Debug.Print "Info: Returning left side from '" & cutBy & "'" Case "rightside" cutString = Left(fullText, position + Len(cutBy) - 1) 'Debug.Print "Info: Returning right side up to '" & cutBy & "'" End Select Else 'Debug.Print "Warning: '" & cutBy & "' not found in fullText. Returning original string." cutString = fullText End If ExitFunction: Exit Function ErrorHandler: Select Case Err.Number Case 13 ' Type mismatch Debug.Print "Error 13: Type mismatch. Ensure all arguments are strings." Case 5 ' Invalid procedure call or argument Debug.Print "Error 5: Invalid argument. Check the function call." Case Else Debug.Print "Unexpected Error " & Err.Number & ": " & Err.Description End Select cutString = fullText Resume ExitFunction End Function ويمكن استخدامها مباشرةً باستبدال هذا الجزء من الكود sqlStr = "SELECT TAB.MNO, TAB.NASS " & _ "FROM TAB " & _ "WHERE TAB.NASS LIKE '*" & Nz(!BookName, "") & "*' " & _ "AND InStr(cutString([NASS],'" & Trim(!BookName) & "','leftSide'),'" & Nz(!B_Hno, "") & "') > 0;" ولكن زاد وقت المعالجة إلي It Takes | 661MS | To resolve | 21 | Records. لقد كنت أجهز للمشاركة ولم اري ردك شوف اقم بالتجربة وسأنتظر ردك بعد تجربة الوظيفة والاضافة الجديدة

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

بالنسبة لرسالة الخطأ الاولي فيمكن حلها بأكثر من طريقة استبدل الكود tabRS.MoveLast tabRS.MoveFirst بهذا On Error Resume Next tabRS.MoveLast tabRS.MoveFirst On Error GoTo 0 اما بخصوص البحث عن الرقم فانا ابحث عن الرقم في كل الحديث لا يهم ان كان قبل النص او بعده في حال كان ناتج البحث 1 فلا يوجد مشكلة في حال كان هناك أكثر من ناتج اقم بتحديد موقع الرقم ومن ثم اذهب الي الوراء حتي اجد اول الرقم ومن ثم اذهب للأمام حتي اجد اخر الرقم وذلك حتي نتمكن من استخراج الرقم ومقارنته بالرقم الأصلي فاذا تطابق نعتمد هذا الناتج وذلك حتي نستطيع التمييز بين 312 و 1312 اذا امكنك مشاركة قاعدة بها احتمالات أكثر حتي نحاول بإذن الله من إيجاد حلول مناسبة

نأمل كتابة العنوان يصف الموضوع ولو بشكل مختصر

في المرفق مربع تحرير يتم الاختيار منه اريد منع الكتابة داخل الحقل والاكتفاء بالاختيار فقط اريد ايسر واخصر طريقة .. وهل في خصائص الحقل ما يدعم هذا المطلب ؟ Database1.accdb

ارفع نموذج للعمل علية ويمكن استخدام دالة Replace اذا فهمت طلبك صح 'مثال txtInput.Value = Replace(txtInput.Value, " ", "__") وهذا مثلا عند حدث عند التحديث

أرجو لك من الله التوفيق وبانتظار نتائج تجاربك لقد قمت بالتعديل علي الملف الأخير الذي قمت بمشاركته 1- اضفت موديول لحساب الوقت حتي تتمكن من حساب وقت العملية 2- قمت بالتطبيق علي الكود ( It Takes | 14MS | To resolve | 21 | Records. ) 3- قمت بتعديل ( Dim totalRec As String ) إلي ( Dim totalRec As Long ) النسخة بالمرفقات والأكواد المعدلة في أخر الموضوع كما أود الإشارة الي هذا السطر في الكود If totalRec Mod 1000 = 0 Then DoEvents وظيفته بشكل مختصر هي توقف تنفيذ الكود كل 1000 سجل حتي يتمكن البرنامج من التحرر وتلقي التحديثات ويحد من مشكلة عدم الاستجابة "Not Responding" لذا يمكنك التعديل علي الرقم 1000 بما يتناسب مع استخدامك مع الاخذ في الاعتبار ان هذا يؤثر علي الوقت الإجمالي للعملية يوجد فيديوهات تشرح الامر بالتفصيل ( كما يمكنك الاطلاع علي الرابط التالي https://wellsr.com/vba/2018/excel/vba-doevents-and-when-to-use-it/ 1- Timer Class MODULE ATTACHED 2- الكود بعد التعديل وتطبيق استخدام (Timer Class MODULE) Public Sub mnoSmartSearch() Dim db As DAO.Database Dim rs As DAO.Recordset Dim tabRS As DAO.Recordset Dim tblName As String Dim sqlStr As String Dim foundMno As String Dim exNum As String Dim stext As String Dim totalRec As Long Dim sPos As Long Dim startPos As Long Dim endPos As Long Dim i As Long Dim sTimer As ahmosTimer Dim itTakes As String tblName = "BOOKS" If DCount("*", tblName) = 0 Then MsgBox "There are no records in the table " & tblName, vbExclamation + vbOKOnly, "No Records Exist Error" Exit Sub End If Set sTimer = New ahmosTimer sTimer.StartTimer Set db = CurrentDb Set rs = db.OpenRecordset(tblName, dbOpenDynaset) With rs .MoveLast .MoveFirst totalRec = .RecordCount Do While Not .EOF sqlStr = "" foundMno = "" If Not IsNull(!BookName) And Not IsNull(!B_Hno) Then sqlStr = "SELECT TAB.MNO, TAB.NASS " & _ "FROM TAB " & _ "WHERE TAB.NASS LIKE '*" & Nz(!BookName, "") & "*' " & _ "AND InStr([NASS],'" & Nz(!B_Hno, "") & "') > 0;" Set tabRS = db.OpenRecordset(sqlStr, dbOpenSnapshot) tabRS.MoveLast tabRS.MoveFirst If tabRS.RecordCount = 0 Then ' No Results found Debug.Print "NotFound", !BookName, !B_Hno ElseIf tabRS.RecordCount = 1 Then ' One Result Found and that what we want foundMno = Nz(tabRS!MNO, "") If foundMno <> "" Then .Edit !MNO = foundMno .Update End If Else ' more than one record found and that shouldn't happen ' Debug.Print "Found Times is : " & tabRS.RecordCount, rs!BookName, rs!B_Hno Do While Not tabRS.EOF sPos = 0 i = 0 startPos = 0 endPos = 0 exNum = "" stext = "" stext = tabRS!NASS sPos = InStr(1, stext, rs!B_Hno) i = sPos Do While i > 0 And IsNumeric(Mid(stext, i, 1)) i = i - 1 Loop startPos = i + 1 ' Move forward to find the end of the number i = sPos Do While i <= Len(stext) And IsNumeric(Mid(stext, i, 1)) i = i + 1 Loop endPos = i - 1 exNum = Mid(stext, startPos, endPos - startPos + 1) If rs!B_Hno = exNum Then .Edit !MNO = Nz(tabRS!MNO, "") .Update Exit Do End If tabRS.MoveNext Loop End If If Not tabRS Is Nothing Then tabRS.Close Set tabRS = Nothing End If Else ' BookName or B_Hno are Empty Debug.Print "BookName or B_Hno are Empty" End If .MoveNext If totalRec Mod 1000 = 0 Then DoEvents Loop End With If Not rs Is Nothing Then rs.Close Set rs = Nothing End If If Not db Is Nothing Then Set db = Nothing sTimer.StopTimer itTakes = sTimer.GetElapsedTime If Not sTimer Is Nothing Then Set sTimer = Nothing Debug.Print "It Takes | " & itTakes & " | To resolve | " & totalRec & " | Records." End Sub Smart_Search03_byAhmos.accdb ahmosTimer.zip

ومشاركة مع اخى الحبيب الأستاذ @Foksh ممكن أيضا مع الحدث "On Key Press" Private Sub Combo4_KeyPress(KeyAscii As Integer) KeyAscii = 0 End Sub وهذا افضل للمصمم ومطور النظم لان ما تفضل بها اخى الحبيب يمنع الدخول الى محرر الاكواد اثناء فتح النموذج من خلال - الضغط على مفتاحى Alt + F11 من لوحة المفاتيح - او من خلال الضغط علىم فتاحى Ctrl +G من لوحة المفاتيح واحيانا نحتاج الى الدخول الى محرر الاكواد بدون اغلاق النموذج لانه احيانا نستخدم امر الطباعة Debug.Print فى الاكواد لتتبع الاكواد وسير الكود لطباعة النتائج فى نافذة Immediate مش قولت لك هافوق لك يا حاج @Foksh كده انا افضل اجابة بالعند فيك

تفضل استاذ @2saad طلبك بالمرفق . mas_s (KK1960)-2.rar

السلام عليكم ورحمة الله وبركاته صبحكم الله بالخير والنور والسرور بارك الله فيكم وفي جهودكم الطيبة أخي الكريم جرب هذا الكود "إن شاء الله يعمل معك" عند التطبيق وجدت اختلاف في قيمة واحدة وهي بالصورة التالية: Public Sub mnoSmartSearch() Dim db As DAO.Database Dim rs As DAO.Recordset Dim tabRS As DAO.Recordset Dim sqlStr As String Dim tblName As String Dim foundMno As String Dim totalRec As String Dim exNum As String Dim stext As String Dim sPos As Long Dim startPos As Long Dim endPos As Long Dim i As Long tblName = "BOOKS" If DCount("*", tblName) = 0 Then MsgBox "There are no records in the table " & tblName, vbExclamation + vbOKOnly, "No Records Exist Error" Exit Sub End If Set db = CurrentDb Set rs = db.OpenRecordset(tblName, dbOpenDynaset) With rs .MoveLast .MoveFirst totalRec = .RecordCount Do While Not .EOF sqlStr = "" foundMno = "" If Not IsNull(!BookName) And Not IsNull(!B_Hno) Then sqlStr = "SELECT TAB.MNO, TAB.NASS " & _ "FROM TAB " & _ "WHERE TAB.NASS LIKE '*" & Nz(!BookName, "") & "*' " & _ "AND InStr([NASS],'" & Nz(!B_Hno, "") & "') > 0;" Set tabRS = db.OpenRecordset(sqlStr, dbOpenSnapshot) tabRS.MoveLast tabRS.MoveFirst If tabRS.RecordCount = 0 Then ' No Results found Debug.Print "NotFound", !BookName, !B_Hno ElseIf tabRS.RecordCount = 1 Then ' One Result Found and that what we want foundMno = Nz(tabRS!MNO, "") If foundMno <> "" Then .Edit !MNO = foundMno .Update End If Else ' more than one record found and that shouldn't happen ' Debug.Print "Found Times is : " & tabRS.RecordCount, rs!BookName, rs!B_Hno Do While Not tabRS.EOF sPos = 0 i = 0 startPos = 0 endPos = 0 exNum = "" stext = "" stext = tabRS!NASS sPos = InStr(1, stext, rs!B_Hno) i = sPos Do While i > 0 And IsNumeric(Mid(stext, i, 1)) i = i - 1 Loop startPos = i + 1 ' Move forward to find the end of the number i = sPos Do While i <= Len(stext) And IsNumeric(Mid(stext, i, 1)) i = i + 1 Loop endPos = i - 1 exNum = Mid(stext, startPos, endPos - startPos + 1) If rs!B_Hno = exNum Then .Edit !MNO = Nz(tabRS!MNO, "") .Update Exit Do End If tabRS.MoveNext Loop End If If Not tabRS Is Nothing Then tabRS.Close Set tabRS = Nothing End If Else ' BookName or B_Hno are Empty Debug.Print "BookName or B_Hno are Empty" End If .MoveNext If totalRec Mod 1000 = 0 Then DoEvents Loop End With If Not rs Is Nothing Then rs.Close Set rs = Nothing End If If Not db Is Nothing Then Set db = Nothing End Sub

لو ده شكلك وانت بتبص ع الاكواد دا كان شكلى وانا باكتبها وافكر فيها

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

تفضل أخي @خالد الماجد 2 ، رغم أن المنتدى مليء بهذه المواضيع ، ولكن بما أنك عضو جديد فأهلاً وسهلاً بك معا في عالمنا الصغير المتواضع في المرفق ستجد طريقتين ، في المديول الأول Hide&Show يتم استدعاء الالة في أول نموذج يعمل في المشروع بالجملة التالية HideAccess لإخفاء واجهة آكسيس ، وأيضاً على العكس تستطيع إظهار آكسيس بالجملة التالية ShowAccess . وفي المديول الثاني Hide_Access هناك أكثر من طريقة للعمل على هذا المديول ، فمثلاً :- لإخفاء واجهة آكسيس : fSetAccessWindow(SW_HIDE) لإظهار واجهة آكسيس : fSetAccessWindow(SW_SHOWNORMAL) لإظهار واجهة آكسيس بوضع التصغير : fSetAccessWindow(SW_SHOWMINIMIZED) لإظهار واجهة آكسيس بوضع ملئ الشاشة : fSetAccessWindow(SW_SHOWMAXIMIZED) Hide & Show.accdb

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

نظرا للطلبات الحالية اظن انه يجب علينا التعديل على اكثر من كود للحصول على النتائج المتوقعة والتعديل كالاتي : Private Sub UserForm_Initialize() 'Code''''''''' '''''''''''''' ' 4اسم المخزن 'Code'''''''''' rw = d.keys ' Sort Combobox 1 Colmun "اسم المخزن" (5) tri rw, LBound(rw), UBound(rw) Me.ComboBox1.List = rw: Me.ComboBox1.ListIndex = 0 'Code'''''''''' 'Sort listbox2 Colmun "الكود" (1) 'القيمة (OneRng, 1) 'ترمز الى رقم العمود الهدف قم بتعديلها بما يناسبك P OneRng, 1, LBound(OneRng), UBound(OneRng) End Sub '******************************** Private Sub ComboBox1_AfterUpdate() 'Code'''''''' Next i rw = j.keys tri rw, LBound(rw), UBound(rw) 'Sort Me.ComboBox2.List = rw Set j = Nothing End Sub '************************************** Sub Filtre() 'Code''''''''''''''''' f.[R2] = Cpt1: f.[S2] = Cpt2 Me.TextBox2 = Format(CStr(f.[X2]), "#,##0.00") If f.[v2] = 0 Then Me.stocktr = f.[U2]: Me.TextBox1.value = Format(f.[W2], "dd/mm/yyyy") Else _ Me.stocktr = f.[V2]: Me.TextBox1.value = Format(f.[T2], "dd/mm/yyyy") 'Code''''''''''''''''' If Me.ComboBox1 = "*" And _ Me.CB_Pièce = "*" Then _ Me.ListBox2.Clear: SubTotal = "": PriceTotal = "": LabelCont = "": TextBox1 = "" End Sub مع نسخ هده الاكواد داخل اليوزرفورم Sub tri(a, gauc, droi) 'Combobox (1-2) ترتيب تصاعدي réf = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < réf: g = g + 1: Loop Do While réf < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub '********************** Sub P(a, V, gauc, droi) 'ترتيب البيانات على الليست بوكس بشرط رقم الكود réf = a((gauc + droi) \ 2, V) g = gauc: d = droi Do Do While a(g, V) < réf: g = g + 1: Loop Do While réf < a(d, V): d = d - 1: Loop If g <= d Then For k = LBound(a, 2) To UBound(a, 2) temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp Next k g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call P(a, V, g, droi) If gauc < d Then Call P(a, V, gauc, d) End Sub اظن اننا استطعنا تنفيد طلبك خطوة بخطوة وهدا افضل بكثير من التعديل على اكواد تم انشاءها مسبقا او طلب اكثر من طلب دفعة واحدة لتستطيع فهم طريقة اشتغال ملفك ويسهل عليك التعديل عليه عند الحاجة مستقبلا sell-the-first-quantity- V7.xlsm

Option Compare Text Dim OneRng(), Rng, rCrit1, rCrit2 Public Property Get f() As Worksheet: Set f = Sheets("Stock") End Property Private Sub UserForm_Initialize() OneRng = f.Range("A4:I" & f.[A65000].End(xlUp).Row).value Rng = UBound(OneRng, 2) 'تنسيق التاريخ For i = LBound(OneRng) To UBound(OneRng): OneRng(i, 9) = Format(OneRng(i, 9), "dd/mm/yyyy"): Next i ' تنسيق عمود السعر For i = 1 To UBound(OneRng): OneRng(i, 3) = Format(OneRng(i, 3), "00.00"): Next i 'Code............ Me.ListBox2.ColumnCount = 9 Me.ListBox2.ColumnWidths = "40;55;60;60;60;0;0;0;50" End Sub عند اختيار مخزن معين فى ComboBox1 لايظهره فى هذا المخزن ComboBox2 وانما يظهر المخازن الاخرى Private Sub ComboBox1_AfterUpdate() If Me.ComboBox1 = "*" Then Me.ComboBox2 = "*" Set j = CreateObject("Scripting.Dictionary") j("*") = "" a = f.Range("E4:E" & f.[E65000].End(xlUp).Row) For i = LBound(a) To UBound(a) If (a(i, 1) <> "") And (Format(a(i, 1), "@") <> Me.ComboBox1.value) Then j(a(i, 1)) = "" Next i Me.ComboBox2.List = j.keys Set j = Nothing End Sub sell-the-first-quantity- V5.xlsm

تنفيذ ماكرو بناء على قيمة خليه2.xlsb تفضل - الملف الأن يرحل تلقائى بدون الحاجة إلى زر للعمل طوال فترة العمل عليه تنفيذ ماكرو بناء على قيمة خليه2.xlsb

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

جرب هذه الفكرة معلمي الفاضل @ابوخليل :) Private Sub Combo4_KeyDown(KeyCode As Integer, Shift As Integer) KeyCode = 0 End Sub

وعليكم السلام الطريقة التي شرحتها في جمع الأرقام ليست علمية كيف تم كتابة الرقم في الخلية على اليمين؟ بناء على ماذا ؟ الرجاء شرح تفصيلي أكثر مع إرفاق ملف

وعليكم السلام -ارفع من فضلك ملف موضح به المطلوب بكل دقة .. فلا يمكن العمل على التخمين وتجنباً لإهدار وقت الأساتذة دون جدوى أو أهمية ؟

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاتة اهلا بكم اعضاء المنتدى الكرام اعتذر جدا للغياب الطويل عن المنتدى ولكن اشتقت اليكم فقولت ارجع بكود ممكن يفيد البعض فى عملة يعتبر البحث عن البيانات من الامور التى يبحث عنها كل مستخدمى الاكسل حيث انها تسهل عليهم اعمالهم وتحليل البيانات لديهم ولكن اذا كان لديك بيانات كثيرة جدا فى شيت الاكسل فالامر هنا يكون شاق ومرهق ومن هنا قررنا انشاء كود بحث من خلال اليوزرفورم يقوم بالبحث عن البيانات وتلوين واظهار نتائج البحث يتم وضع الكود فى حدث التكست بوكس Dim Itemsaerch As String Dim rng As Range Dim cell As Range Dim lr As Long Sheet1.Cells.Interior.Pattern = xlNone Itemsaerch = Me.TextBox1.Value lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row Set rng = Sheet1.Range("a2:a" & lr) For Each cell In rng If InStr(1, cell.Value, Itemsaerch) > 0 Then cell.Interior.Color = vbGreen End If Next cell If Me.TextBox1.Value = "" Then Sheet1.Cells.Interior.Pattern = xlNone ملف العمل فورم بحث جديد وتلوين نتائج البحث.xlsm

مشاركة مع استاذى @Moosak تفضل استاذ @alharazi97 محاولاتي حسب فهمي للطلبين الأول والثاني ، بالفيديو والمرفق. ووافني بالرد . الترقيم بالفورم حسب السنة والاختيار المتعدد.rar

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