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

السلام عليكم ورحمة الله تعالى وبركاته عارف ان الموضوع قديم وانا كنت قلت عاوز لها روقان واحلى سطل شاى وللاسف كان عندى مشكلة فى الشاى وبمجرد حل المشكلة عدت اليكم سريعا شوفوا انا بصراحة كنت بدأت في التصميم ولا اعرف سبب انشغالي واليوم وانا ابحث عن شيء في حاسوبي وجدت المرفق وتذكرت الموضوع وقررت ان اكمل ما بدأته أعجبتني أفكار الأستاذ @Moosak وختامها مسك طبعا ابهرني أستاذي الجليل ومعلمي القدير الأستاذ @أبو إبراهيم الغامدي ساحر ربط الاكس بلغة الـ HTML وأخيرا أفكاري المتواضعة OfficenaPattern.accdb

السلام عليكم ورحمة الله تعالى وبركاته جرب هدا =IFERROR(INDEX(اجمالي6!$A$4:$A$600;AGGREGATE(15;6;ROW(اجمالي6!$A$1:$A$600)/(اجمالي6!$AH$4:$AH$600="ذكر")/(اجمالي6!$AE$4:$AE$600="ناجح ومنقول للصف الأول الاعدادي");ROW(اجمالي6!A1));1);"") TEST.xlsx

يسعدنا اننا استطعنا مساعدتك ادن اليك حل اخر في حالة عدم الرغبة باستخدام المعادلات Sub ExtractFromText2() Dim arr() As String, Cell As Range, i As Integer, lr& Set WS = Sheets("ATIF") Application.ScreenUpdating = False WS.Range("b2:C" & WS.Rows.Count).ClearContents lr = WS.Cells(Rows.Count, "A").End(xlUp).Row For Each Cell In Range("A2:A" & lr) arr = Split(Trim(Cell), "-") If UBound(arr) <> 0 Then For i = 0 To UBound(arr) Cell.Offset(, i + 1) = arr(i) Next End If Next Application.ScreenUpdating = True End Sub '*********OR*********** Sub ExtractFromText3() Dim r As Range, lr& Set WS = Sheets("ATIF") Application.ScreenUpdating = False With WS .Range("B2:C" & .Rows.Count).ClearContents lr = .Cells(Rows.Count, "A").End(xlUp).Row For Each r In Range("A2:A" & lr) .Range(r.Offset(0, 1), r.Offset(0, 2)).Value = Split(r, "-") Next r End With Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله تعالى وبركاته اعرف ان الفكرة نوعا ما ليست جديدة كليا ولكن انا قمت بتطوير الفكرة بقدر الإمكان وفق رؤيتي القاصرة المرفق والفكرة مازالت قيد التجربة والتطوير لذلك اطلب العفو والسماح في حال وقوع أي أخطاء في انتظار آرائكم وارحب بإضافة الأفكار طبعا و يحبذا لو يتم تطبيق عمليا على المرفق مباشرة وإعادة رفعه من جديد OfficenaSQL2VBA.accdb

هل جربت شيء كهدا If WS.Range("DZ" & j) Like clé or WS.Range("DZ" & j) like "غ" then

منور الحتة يباش مهندس 😊🌹

بص حضرتك هى كل الفورم التانيه هتاخد default بتاعها من من نفس الجدولfixed_tbl يعنى الجدول دا انا مجمعه فيه كل نتايج التحاليل اللى بتحتاج فورم كامله لوحدها زى URINE بول STOOL براز SEMEN سائل منوى STOONE حصوه CSF سائل النخاع الشوكى

بسيطه إن شاءالله شوفي لو عايزه تعملي حاجه تانيه بالمره مفيش مشكله 🤓

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

رووووعاتك ايها الجراح العظيم 😉😉😉

كلنا مبسوطييييين منها الحمدلله 😄🖐 طب دالوقتي بعد ما عملت ريستارت للسستم بتوعك إشرح لنا الحلاوة دي 😁

تم الغاء الداله حسب فهمي بما ان الحقول المفروض تاخد من الجدول الفاضي تم عمل سجل فالجدول الفاضي للتجربه عليه safaa n.accdb

اليك الحلول التالية يمكنك اختيار ما يناسبك test.xlsx

وعليكم السلام ورحمة الله وبركاته 🙂 لأ الشاي جاب النتيجة المطلوبة ما شاء الله 😄👌

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

وعليكم السلام 🙂 يجب إعطاء الامر Me.Requery ومعناها اجلب البيانات الجديدة من مصدر بيانات النموذج (Me معناه انا الكائن الذي تتم العمليه من خلاله ، اي مكان الحدث الذي اتى منه امر الحذف مثلا) ، بعد كل عملية تغيير في الجداول ، سواء حذف بيانات (مثل ما عندك) ، او اضافة او تغيير. وممكن عمل تحديث بيانات نموذج آخر (غير النموذج الذي تم الامر من خلاله) ، فيصبح الامر Forms!frnName.requery جعفر

هناك أكثر من موضوع في المنتدى تناول شيت الجدارات https://www.officena.net/ib/topic/124499-تحديد-اوائل-القسم-في-امتحان-نهاية-العام-_-شيت-جدارات/ و هذا https://www.officena.net/ib/topic/121181-شيت-كنترول-جدارات-_-قسم-حاسبات-_-مفتوح-المصدر/

السلام عليكم وهذه مشاركة مع استاذي @ابو جودي مرفق قاعدة تحويل الاستعلام الى VBA على شكل سلسة strSql = "UPDATE TABABC SET " & vbCrLf strSql = strSql & " TABABC.HNUMB = 785 " & vbCrLf strSql = strSql & " ,TABABC.BCOD = ""tty"" " & vbCrLf strSql = strSql & " ,TABABC.GCOD = ""yemen"" " & vbCrLf strSql = strSql & " WHERE (((TABABC.DNUMB)=96) " & vbCrLf strSql = strSql & " AND ((TABABC.ECOD)=False));" CurrentDb.Execute (strSql), dbFailOnError ConvertSQL_TO_VBA.accdb

مشاركة مع معلمي واستاذي @jjafferr تفضل استاذ @2saad طلبك حسب مافهمت . ووافني بالرد . تجربة-1.rar

وعليكم السلام ورحمة الله تعالى وبركاته هل هدا ما تقصده Sub Macro1() Msg = MsgBox("تفريغ البيانات ؟", vbYesNo, "تأكيد") If Msg <> vbYes Then Exit Sub Application.ScreenUpdating = False [D5:K18].ClearContents Application.ScreenUpdating = True End Sub

**كود VBA لإظهار "راسب" للطلاب الذين لم يحصلوا على ربع درجة النجاح في الترم الثاني** Sub CheckPassFail() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Sheet1") 'استبدل "Sheet1" باسم ورقة العمل الخاصة بك Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If ws.Cells(i, "D").Value < 5 Then 'عمود الدرجات ws.Cells(i, "E").Value = "راسب" 'عمود النتيجة End If Next i End Sub **خطوات الاستخدام:** 1. انسخ الكود والصقه في وحدة نمطية في دفتر عمل Excel الخاص بك. 2. استبدل "Sheet1" في سطر `Set ws = ThisWorkbook.Worksheets("Sheet1")` باسم ورقة العمل التي تحتوي على بيانات الطلاب. 3. قم بتشغيل الكود بالنقر فوق الزر "تشغيل" في علامة التبويب "المطور" أو باستخدام اختصار لوحة المفاتيح `F5`. **ملاحظات:** * يفترض الكود أن عمود الدرجات هو العمود "D" وعمود النتيجة هو العمود "E". * إذا لم يكن لديك عمود نتيجة، يمكنك إضافة واحد يدويًا أو تعديل الكود لتحديث عمود آخر. * يمكنك تخصيص الكود لتناسب احتياجاتك المحددة، مثل تغيير قيمة درجة النجاح أو تغيير النص الذي يتم عرضه للطلاب الراسبين.

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الكريم Option Explicit Sub Découpe_45() Dim WS As Worksheet, WS2 As Worksheet Dim i As Long, j As Long, k As Long, x As Long Dim Cpt As Long, r As Long, headers As Range Set WS = ThisWorkbook.Sheets("ورقة1"): Set WS2 = ThisWorkbook.Sheets("ورقة3") Application.ScreenUpdating = False With WS2.Range("A4:F" & WS2.Rows.Count) .Cells.ClearFormats: .Cells.ClearContents End With j = 5: Cpt = 45: Set headers = WS.[A4:F4] k = WS.Range("A:F").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row For i = j To k Step Cpt If i = j Then headers.Copy Destination:=WS2.[A4] WS.Range("A" & i & ":F" & i + Cpt - 1).Copy Destination:=WS2.Range("A" & j) Else x = WS2.Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 7 headers.Copy Destination:=WS2.Range("A" & x) WS.Range("A" & i & ":F" & i + Cpt - 1).Copy Destination:=WS2.Range("A" & x + 1) End If Next i For r = 1 To 6 WS2.Cells.EntireRow.AutoFit WS2.Columns(r).ColumnWidth = WS.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Application.ScreenUpdating = True End Sub جدول 2024.xlsb

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, 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, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

وعليكم السلام ورحمة الله وبركاته على حسب ما فهت تفضل هذا مثال1.xlsx

استاذ @حسين مامون شرح أكثر من ممتاز .جزاك الله خير.

يسعدني أن أكون أول المعلقين ، هذا لأنك من المبدعين القليلين أخي @Moosak ، وما يعجبني في نمط نفكيرك إنه خلّاق ومبتكر أبدعت جداً ، وعمل جميل وتصميم أنيق يليق بشخص أنيق

بعد اذن اخى الحبيب استاذ احمد بدره واستاذ احمد يوسف المضوع بسيط لا يحتاج الى ملفين انظر الى هذا الملف لعله يفى بالغرض نسخة من 1111.xlsx