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

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

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

بطريقة اخرى 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

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

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

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

شكرا بارك الله فيك فعلا انتا موسوعة اكسل @محمد هشام.

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

بارك الله فيكم

شكرا لك أخي فريد @فريدالطحان على الهدية والمشاركة 🙂 وأهلا وسهلا بك دائما 🌷

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

غريب صراحة لا اعلم لمادا لانني جربت الملف عندي ويشتغل بشكل جيد و بدون ادنى مشكلة وللتأكد قمت بتجربته على جهاز اخر انظر الرابط التالي 👇 https://streamable.com/3m40n4 رغم انني متأكد من صحة الاكواد وبما ان كود التنازلي يعمل جرب هدا للتصاعدي و الترتيب الابجدي ووافينا بالنتيجة Sub Tri_Names_Ordre() 'ترتيب ابجدي 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) ' <<=======عمود الاسم======== Call Quick(a(), LBound(a), _ UBound(a), 1, True): r.Value2 = a End Sub '************* Sub Tri_Ordre_croissant() 'ترتيب تصاعدي 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) ' <<=======عمود المجموع======== Call Quick(a(), LBound(a), _ UBound(a), 7, True): r.Value2 = a End Sub فرز V4.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

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

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

طهور ان شاء الله اخي واستاذ @Foksh واسال من الله ان يشفيك شفاء لا يغادر سقما

ربنا يشفيه ويعافيه يارب ويباركله في صحته وعافيتة

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

طهورا ان شاء الله

بعد ادن الاستاد انظر المرفق يمكن اضافة اضافة مربعات نص اخرى كمان يمكن الطباعة بدل الاستعلام test.accdb

هو فعلا بروف يا جراحنا العظيم

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

شفاك الله وجمع لك بين الأجر والعافية .. طهور ان شاء الله عجزت ايه بس يا عم انت هتتدلع انشف كده 😡 ايه الجيل ده يا ربى

الف مليون سلامة عليك ربنا يكرمك ويشفيك ويديم عليك صحتك

نسال الله سبحانه وتعالى الشفاء العاجل لاخينا @Foksh او فادي

الف سلامة علي حضرتك وربنا يتم شفاك علي خير باذن الله🌺

دا أقل شئ يا غالي وحمدالله علي سلامتك يا بروف ☺️☺️