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

وعليكم السلام خيار آخر Sub Test() Dim a Dim i& Application.ScreenUpdating = False a = Cells(7, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) & a(i, 2) <> "" And a(i, 1) <> 0 And a(i, 2) <> "" And a(i, 1) <> "" And WorksheetFunction.IsNumber((a(i, 1))) Then If Not .exists(a(i, 1) & "|" & a(i, 2)) Then .Add a(i, 1) & "|" & a(i, 2), "" End If Next Cells(7, 5).Resize(.Count) = Application.Transpose(.keys) Application.DisplayAlerts = False Cells(7, 5).Resize(.Count).TextToColumns Destination:=Range("E7"), OtherChar:="|", FieldInfo:=Array(2, 1) End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا ما تقصد Option Explicit Sub Test() Dim i&, F&, K&, R&, lastrow& Dim Rng As Variant Dim Réf As Variant Dim DelRng As Range Dim sh As Worksheet: Set sh = Sheets("Sheet1") lastrow = sh.Columns("A:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Application.ScreenUpdating = False sh.Range("E7:F" & lastrow).ClearContents Rng = sh.Range("A7:B" & lastrow).Value ReDim Réf(1 To UBound(Rng, 1), 1 To UBound(Rng, 2)) F = 1 For i = LBound(Rng, 1) To UBound(Rng, 1) If Rng(i, 1) <> "" And Rng(i, 1) <> "الصافي" And Rng(i, 2) <> "" Then For K = LBound(Rng, 2) To UBound(Rng, 2) Réf(F, K) = Rng(i, K) Next K F = F + 1 End If Next i sh.Range("E7").Resize(F - 1, UBound(Réf, 2)).Value = Réf With sh For R = lastrow To 7 Step -1 'حدف العناوين 'If .Cells(R, "A").Value = "" Or .Cells(R, "B").Value = "" Or .Cells(R, "A").Value = "الصافي" Then If .Cells(R, "A").Value = Empty Or .Cells(R, "B").Value = Empty Then Set DelRng = .Range(.Cells(R, 1), .Cells(R, 2)) DelRng.Delete Shift:=xlUp End If Next R End With Application.ScreenUpdating = True End Sub 222222.xlsm

قمت بتعديل الترقيم 🙂 : Sum Them All - Moosak.accdb

يمكنك الترتيب تنازليا لتحصل على الأصغر أولا

وعليكم السلام أخي الكريم أدرج موديول جديد وضع الدالة المعرفة التالية في الموديول Function xDupsV(fCol As Range, Optional offsetCol As Integer = -1) Dim a, r1 As Range, r2 As Range, c As Range, cc As Range, i As Long, j As Long Application.Volatile True Set r1 = fCol Set r2 = r1.Offset(, offsetCol) ReDim a(1 To 1) For Each c In r1 Set cc = c.Offset(, offsetCol) If Not IsEmpty(c) And cc > 0 Then For j = 1 To cc i = i + 1 ReDim Preserve a(1 To i) a(i) = c Next j End If Next c xDupsV = WorksheetFunction.Transpose(a) End Function ثم في الخلية C11 ضع المعادلة بهذا الشكل =xdupsv(F3:F6) لا تنسى أن تقوم بمسح النطاق C11 إلى آخر النطاق قبل وضع المعادلة

لها أكثر من حل يمكنك تجربب هذا keab.Text5.Value = CDate(keab.Text3.Value) + Int(keab.Text4.Value) - 1 بالتوفيق

هذه اداة لعمل خطوط رسم البيانى والموسيقى والانجليزى فى الورقة Graph Paper Printerعمل رسم بيانى.rar

بارك الله فيك أداة رائعة ومجانية وهذا إصدار 4.03 وإليكم الإصدار الأحدث 4.21 بالتوفيق

تم بحمد الله 🙂 ما رأيك في هذه النتيجة ؟ ( قمت بتغيير تشكيلة الجدول عن المثال الذي أرفقته لتسهيل قرائة الأرقام 🙂 ) وهذا هو الكود الذي ينفذ الأمر : Option Compare Database Option Explicit Private Sub DoSumBtn_Click() '"planWWB" '"Temp_Sum_T" On Error GoTo HandleError Dim db As DAO.Database Dim Rs1 As DAO.Recordset Dim Rs2 As DAO.Recordset Dim x As Long, i As Integer x = 1 CurrentDb.Execute "DELETE * FROM Temp_Sum_T;" Set db = CurrentDb Set Rs1 = db.OpenRecordset("SELECT * FROM planWWB ORDER BY m;") If Not Rs1.BOF And Not Rs1.EOF Then Rs1.MoveFirst While (Not Rs1.EOF) For i = 3 To 6 CurrentDb.Execute "INSERT INTO Temp_Sum_T (No, m, Operation1, Result1 ) " & _ "VALUES (" & x & "," & Rs1!m & ",'" & Rs1.Fields(i).Name & "'," & Rs1.Fields(i).Value & ");" Set Rs2 = db.OpenRecordset("SELECT * FROM planWWB where m <> " & Rs1!m & " ;") If Not Rs2.BOF And Not Rs2.EOF Then Rs2.MoveFirst While (Not Rs2.EOF) Dim s1 As String, s2 As String, s3 As String, s4 As String s1 = Rs1.Fields(i).Name & " + " & Rs2.Fields(3).Name s2 = Rs1.Fields(i).Name & " + " & Rs2.Fields(4).Name s3 = Rs1.Fields(i).Name & " + " & Rs2.Fields(5).Name s4 = Rs1.Fields(i).Name & " + " & Rs2.Fields(6).Name CurrentDb.Execute "INSERT INTO Temp_Sum_T (No, m, m2, Operation1, Result1, Operation2, Result2, Operation3, Result3, Operation4, Result4 ) " & _ "VALUES (" & x & "," & Rs1!m & "," & Rs2!m & ",'" & _ s1 & "'," & (Rs1.Fields(i).Value + Rs2.Fields(3).Value) & ",'" & _ s2 & "'," & (Rs1.Fields(i).Value + Rs2.Fields(4).Value) & ",'" & _ s3 & "'," & (Rs1.Fields(i).Value + Rs2.Fields(5).Value) & ",'" & _ s4 & "'," & (Rs1.Fields(i).Value + Rs2.Fields(6).Value) & ");" Rs2.MoveNext DoEvents Wend End If Next i x = x + 1 Rs1.MoveNext DoEvents Wend End If Rs1.Close Rs2.Close Set db = Nothing Set Rs1 = Nothing Set Rs2 = Nothing DoCmd.OpenTable "Temp_Sum_T" MsgBox "تم جمع كل السجلات" HandleExit: Exit Sub HandleError: If Err.Number = 0 Then Resume Next Else MsgBox Err.Number & vbNewLine & vbNewLine & Err.Description End If Resume HandleExit End Sub لحذف الحسابات السابقة وإعادة الحساب من جديد تضغط على الزر : الملف : Sum Them All - Moosak.accdb

ارفق مثال للتطبيق عليه اخي الكريم

شكرا لك اخي الفاضل

شكرا استاذ العزيز هذا ماكنت اريده ....جزاكم الله خيرا ... واشكر كل اساتذة الذين ساهموا في الموضوع ولكم مني اجمل تحية...

اتفضل تم تنفيذه على مثال المهندس / قاسم DD227-2.rar

مع ان السؤال موجه للاساتذة الكبار جرب في الاستعلام اكتب not null سيقوم الاكسيس بتصحيح المعيار الى Is Not Null وليس not is null وكلاهما يعملان اما في محرر الاكواد فكما اشار ابوخليفة والله اعلم

ربما يفيد هذا الرابط ونتائج البحث عن الفرق بين تاريخين https://www.officena.net/ib/search/?q=الفرق بين تاريخين&quick=1&type=forums_topic&nodes=135&updated_after=any&sortby=relevancy&search_and_or=and بالتوفيق

تفضل

هل تصوري لمطلوبك صحيح ؟؟؟؟؟

أخي @Abdelaziz Osman اذا كان هذا طلبك لا تنسى الضغط على أفضل اجابة .

السلام عليكم ورحمة الله إذا كانت القيمة المراد تقريبها موجودة في الخلية A2 (مثلا) فيمكن استعمال المعادلة التالية (في أي خلية أخرى): =IF(MOD(A2;100)<=50;100*INT(A2/100);100*(INT(A2/100)+1)) أو =IF(MOD(A2,100)<=50,100*INT(A2/100),100*(INT(A2/100)+1)) والله أعلم

IFERROR(LOOKUP(A1,{600001;700001;800001;900001},{525;2775;5025;8025}) بسيطة وسهلة هذا الجزء يعنى ان الشرائح التى تبدأ بـــ600001 يكون الوعاء الضريبى هو المقابل لها بالقوسين الأخرين وهو 525 أما الشريحة الثانية 700001 فالوعاء الضريبى لها هو 2775 ...وهكذا الى اخر الشرائح وشكراً

وعليكم السلام ورحمة الله تعالى وبركاته المشكلة ليست في الحل اخي سعد طلبك ليس بالسهل يجب ان تعلم ان عكس اظهار البيانات على الليست بوكس يتطلب تعديل اكواد الترحيل والتعديل والحذف ...وهدا يلزمه بعض الوقت . Dim Col(), WSData, Largeur(), MyRng, ligne, F, ColSearch(), J Private Sub UserForm_Initialize() Dim A, B, C, D ' اسماء الجداول A = [Tableau1]: B = [Tableau2]: C = [Tableau3]: D = [Tableau4] ' التعامل مع ورقة العمل النشطة Set WSData = ActiveSheet ' نطاق البيانات Set MyRng = WSData.Range("C10:M" & WSData.[C65000].End(xlUp).Row) F = WSData.Range("C10:M" & WSData.[C65000].End(xlUp).Row).Value ' ترتيب الاعمدة الظاهرة على الليست بوكس Col = Array(11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1) ' عرض الاعمدة Largeur = Array(60, 50, 60, 80, 65, 75, 75, 80, 170, 50, 15) Me.ListBox2.ColumnCount = UBound(Col) + 1 Me.ListBox2.ColumnWidths = Join(Largeur, ";") ' اظهار البيانات على الليست بوكس On Error Resume Next Me.ListBox2.List = Application.Index(MyRng, Evaluate("Row(1:" & MyRng.Rows.Count & ")"), Col) On Error GoTo 0 'اعمدة خاصة بفلترة الليست بوكس ColSearch = Array(11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1) ' تم تحديد عمود اسم الطالب (يمكنك تعديله) J = UBound(ColSearch) + 1 'عناوين الليست بوكس Transférer Me.ListBox1.Visible = False Me.Show_file.Caption = "إظهار ملف العمل" ' رقم الصف ligne = WSData.[C65000].End(xlUp).Row + 1 Me.N_Row = ligne ' عدد الصفوف على الجداول NbLigne = [Tableau1].Rows.Count + [Tableau2].Rows.Count + [Tableau3].Rows.Count + [Tableau4].Rows.Count If Me.ComboBox1.Value = Empty Then Counter.Caption = "المجموع" & " / " & NbLigne Else Counter.Caption = Me.ComboBox1.Text & " / " & ListBox2.ListCount + 0 End Sub '******************************* Sub Transférer() On Error Resume Next i = 0 For Each C In Col i = i + 1 Me("MH" & i).Caption = MyRng.Offset(-1).Item(1, C) Next End '****************************** Sub Search() students_name = "*" & Me.TextBox12 & "*" Dim Tbl(): n = 0 For i = 1 To UBound(F) If F(i, 3) Like students_name Then ' فلترة باسم الطالب n = n + 1: ReDim Preserve Tbl(1 To J, 1 To n) C = 0 For Each k In ColSearch C = C + 1: Tbl(C, n) = F(i, k) Next k End If Next i If n > 0 Then Me.ListBox2.Column = Tbl Else Me.ListBox2.Clear End Sub محمد_3.xlsm

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

وعليكم السلام ورحمه الله وبركاته راجع المرفق تم عمل المطلوب ان شاء الله بحث.xls