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

هل هذا طلبك ......

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

بسيطة 😉 سوف أحاول تعديل الأكواد السابقة على هذا الملف بطريقة مختلفة لتتمكن من عرض البيانات بالشكل المطلوب مع بعض التحسينات تفضل اخي @عادل ابوزيد Option Explicit Private Const Mysh_Name As String = "البداية" Private Const MyFind_Column As Integer = 5 Private Const iHeight As Integer = 20 Private iGblInhibitTextBoxEvents As Boolean Private Sub UserForm_Initialize() kh_Add_Labels Me.Frame2, 5 Me.Frame2.BorderStyle = 0 End Sub Private Sub kh_Add_Controls(MyCont As Control, MyTop As Double, MyHeight As Double, iRo As Long, rowData() As String) Dim MyTxt As Control Dim i As Integer Dim tmp As Double Dim Colarr(1 To 12) As Double Dim columnHeights(1 To 12) As Double Dim defaultWidths As Variant defaultWidths = Array(68, 80, 80, 130, 170, 110, 80, 90, 80, 80, 80, 115) For i = 1 To 12 Colarr(i) = defaultWidths(i - 1) columnHeights(i) = 25 Next i tmp = 0 For i = UBound(rowData) To 1 Step -1 Set MyTxt = MyCont.Add("Forms.TextBox.1", Cells(iRo, 3 + i - 1).Address, True) With MyTxt .Move tmp, MyTop, Colarr(i), columnHeights(i) .Text = rowData(i) .TextAlign = fmTextAlignRight .Font.Size = 13 .Font.Name = "Times New Roman" .BorderStyle = fmBorderStyleSingle .BorderColor = RGB(128, 128, 128) End With tmp = tmp + Colarr(i) + 0.15 Next i Set MyTxt = Nothing End Sub Private Sub kh_Add_Labels(MyCont As Control, MyTop As Double) Dim i As Integer Dim MyLabel As Control Dim tmp As Double Dim Colarr(1 To 12) As Double Dim defaultWidths As Variant defaultWidths = Array(72, 80, 80, 130, 170, 110, 80, 90, 80, 80, 80, 115) For i = 1 To 12 Colarr(i) = defaultWidths(i - 1) Next i Dim spacing As Double spacing = 0.15 tmp = 0 For i = 12 To 1 Step -1 Set MyLabel = MyCont.Add("Forms.Label.1", "Label" & i, True) With MyLabel .Caption = Worksheets("البداية").Cells(6, 3 + i - 1).Value .Move tmp, MyTop, Colarr(i), 20 .TextAlign = fmTextAlignCenter .Font.Size = 14 .Font.Name = "Times New Roman" .BorderStyle = fmBorderStyleSingle .BorderColor = RGB(192, 192, 192) .BackColor = RGB(51, 204, 204) End With tmp = tmp + Colarr(i) + spacing Next i Set MyLabel = Nothing End Sub Private Sub kh_Find(MyText As String) Dim MyHght As Double, MyTp As Double Dim Last As Long, ii As Long, i As Long Dim Found As Boolean Found = False MyTp = 0 Application.ScreenUpdating = False With Worksheets(Mysh_Name) Last = .Cells(.Rows.Count, MyFind_Column).End(xlUp).Row For ii = 2 To Last If CStr(.Cells(ii, MyFind_Column)) Like IIf(Me.Check_Text.Value, "", "*") & MyText & "*" Then MyHght = .Rows(ii).RowHeight Dim rowData(1 To 12) As String For i = 3 To 14 If i = 4 Or i = 9 Or i = 11 Or i = 12 Or i = 13 Then If IsDate(.Cells(ii, i).Value) Then rowData(i - 2) = Format(.Cells(ii, i).Value, "yyyy/mm/dd") Else rowData(i - 2) = CStr(.Cells(ii, i).Value) End If Else rowData(i - 2) = CStr(.Cells(ii, i).Value) End If Next i If MyHght < iHeight Then MyHght = iHeight kh_Add_Controls Me.Frame1, MyTp, MyHght, .Cells(ii, MyFind_Column).Row, rowData MyTp = MyTp + MyHght + 2 Found = True End If Next End With If Not Found Then MsgBox TextBox_Find.Value & " " & "رقم الملف غير موجود", vbExclamation Me.TextBox_Find.Value = "" End If If MyTp >= Me.Frame1.Height Then Me.Frame1.ScrollHeight = MyTp Application.ScreenUpdating = True End Sub تنسيق الفورم.rar

ان شاء الله قريباً سيتم ادراج أول نسخة من الإصدار الجديد ( 5 مراحل ) ان شاء الله ، ويهمني رأي من يتابع الفكرة ليست لأنها لعبة ، بل بتوظيف آكسيس فوق ما هو معهود عليه من قدرات ويسعدني ردك مهندس عمر

من غير ما اشوف اكيد اكيد هتكون رائع لكن اكيد ان شاء الله غدا بجرب واعطيك ردي

في التحديث الجديد ، تم اعتماد نفس نمط المتاهة ولكن مع تغيير وتحديث المستوى من 1 - 30 ، حيث سيكون في كل مستوى متقدم لغز جديد يختلف عن السابق وبتصاعد وتيرة التحدي من السهل الى الصعب في آخر مستوى ( المستوى 30 ) . جميع التعديلات في نمط المتاهة من تعديلي وتصميمي وهذا شكل التصميم الذي تم اعتماده تقريباً ؛ ما لم يطرأ أي تحديث للأفضل .

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد @أبومروان لتجنب الفراغات يمكنك تجربة هدا الخلية A5 =IF($C$2<>"",TEXT(B5, "dddd"),"") او =IF(C2="", "", FILTER(CHOOSE(WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1), "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"), WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1))) الخلية B5 =IF(C2="", "", FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5))) لانشاء قائمة شهور السنة =EOMONTH(DATE(2024, 1, 1), ROW(A1)-2) + 1 أيام الشهر من يوم محدد.xlsx

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

الحمد لله اعانك الله ووفقك

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

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

اخي الكريم @عمر ضاحى جزاك الله خيرا هو ده بالظبط اللي كنت محتاجه واتعلمت منه بشكرك جدا جدا جدا

مرفق ملف للإصدارات الـ 32 Haze Game (32 Bit).zip

معك حق في هذه النقطة ( لكن حالياً انا عندي النظام 64 ، ولكن ثق تماماً أني سأرفق لك ولأصحاب الإصدارات الـ 32 بت نسخة مخصصة ) ، والهدف هو ليس التقييم باإعداب وإنما للملاحظات والتطويرات ليس أكثر . أشكرك على الكلام اللطيف صديقي المهندس عمر .. تمام الحمد لله ، مع العلم ان هذه النسخة فقط بدائية وقيد التطوير بنظام أجمل ومراحل تصل إلى 30 مرحلة ..

اتفضل هذه فكرتي التى تم ذكرها سابقا ProgressBar.rar

لو فضيت 10 دقايق ان شاء الله بعملك حاجه توضح الفكره لكن حاول انت من طرفك علشان تتعلم

لو ركزت فى كلامي هتلاقيني معطيك الحل هي شاشة تحميل واحده فقط تكفي للكل

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

لماذا؟ هذا سيجعل فى كل مره انتظر لحين الانتهاء من الحدث ثم يقوم بفتح التقرير عموما هذا يرجع لك كل ال عليك كفكره هتعلن عن متغير عام عند تشغيل الشاشه الرئيسيه هيخزن فيه اسم النموذج او التقرير وفى حدث عند الغلق لشريط التحميل يفتح التقرير او النموذج او عند اكتمال الشريط يغلق الشريط و يفتح النموذج او التقرير

وعليكم السلام اتفضل مثال_1.accdb

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

شرح الكود من العم أبو ذكاء 😁🖐: هذا الكود هو جزء من تطبيق يستخدم لغة VBA (Visual Basic for Applications) لإنشاء شريحة جديدة في برنامج PowerPoint والتقاط صورة منها. إليك شرحًا لوظيفة كل جزء من الكود: ### وظيفة الكود: 1. **إعداد المتغيرات**: - يتم تعريف مجموعة من المتغيرات (مثل `PptApp`, `PptDoc`, `Diapo`, `Sh`, `Sh1`) للتعامل مع كائنات PowerPoint. 2. **إنشاء تطبيق PowerPoint جديد**: - يتم إنشاء مثيل جديد من PowerPoint وفتح عرض تقديمي جديد. 3. **إضافة شريحة جديدة**: - يتم إضافة شريحة جديدة إلى العرض التقديمي وتعيين تخطيطها إلى فارغ (`ppLayoutBlank`). 4. **إضافة شكل مستطيل**: - يتم إضافة شكل مستطيل إلى الشريحة ليكون خلفية بيضاء. 5. **إضافة نص**: - يتم إضافة تسميات نصية إلى الشريحة، مع تحديد النص ولون الخط وحجمه. النص يتم الحصول عليه من خاصية `Me.note`، وإذا كان فارغًا يتم استخدام القيمة الافتراضية "kanory". 6. **توسيع الشكل ليناسب النص**: - يتم ضبط حجم الشكل تلقائيًا ليناسب النص المضاف. 7. **توسيع الشكل في وسط الشريحة**: - يتم تحديد موقع الشكل ليكون في وسط الشريحة. 8. **حفظ الشريحة كصورة**: - يتم حفظ الشريحة كصورة بتنسيق JPG في مجلد معين. 9. **إغلاق PowerPoint**: - بعد حفظ الصورة، يتم إغلاق العرض التقديمي وتطبيق PowerPoint. 10. **نسخ الصورة**: - يتم التحقق مما إذا كانت الصورة قد تم حفظها بنجاح. إذا كان هناك ملف صورة، يتم نسخه إلى موقع آخر مع اسم محدد. بعد ذلك، يتم حذف النسخة الأصلية. ### ملخص: الكود يقوم بإنشاء شريحة في PowerPoint، يضيف إليها نصًا وشكلًا، ثم يقوم بحفظ الشريحة كصورة JPG في مجلد محدد. في النهاية، ينسخ الصورة إلى اسم جديد (إذا لزم الأمر) ويحذف النسخة الأصلية.

وعليكم السلام ورحمة الله تعالى وبركاته للحصول على النتائج بالترتيب المطلوب يمكنك استخدام الصيغة التالية للحصول على الأسماء التي تتضمن القيمة ب USD في الخلية A3 =UNIQUE(FILTER(Sheet1!A2:A45, Sheet1!G2:G45<>"")) وفي الخلية C3 =IF(A3<>"", SUMIFS(Sheet1!$G$2:$G$45, Sheet1!$A$2:$A$45, A3), "") مع سحبها لغاية اخر صف به بيانات من الأسماء المستخرجة وبعد اخر صف به بيانات على العمود A ضع المعادلة التالية لجلب الأسماء التي تتضمن EGP =UNIQUE(FILTER(Sheet1!A2:A45, Sheet1!F2:F45<>"")) وبنفس الطريقة في اخر خلية بها بيانات من عمود C =IF(A16<>"", SUMIFS(Sheet1!$F$2:$F$45, Sheet1!$A$2:$A$45, A16), "") Suppliers.xlsx أنصحك أخي @هانى محمد باستخدام الأكواد لتتمكن من الحصول على النتائج المطلوبة بطريقة ديناميكية دون تقييد لخلايا وضع المعادلات خاصة ادا كانت البيانات غير ثابتة وقابلة للزيادة مما سوف يساعدك على الإشتغال على الملف بشكل مرن ومطاطي وحصولك على النتائج بالترتيب المطلوب جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim LastRow As Long, n As Long, a As Collection, b As Collection Dim TotalG As Double, TotalF As Double, Kay As Variant, rng As Range Dim ColG As Variant, ColF As Variant, i As Long Dim Irow As Long, j As Variant, totals As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Total") If Not Intersect(Target, WS.Range("A2:G" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False On Error Resume Next Dim tbl As ListObject Set tbl = dest.ListObjects(1) If Not tbl Is Nothing Then tbl.Unlist End If On Error GoTo 0 LastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row If LastRow >= 3 Then dest.Range("A3:D" & LastRow).Clear End If If dest.Cells(2, "A").Value = "" Then dest.Range("A2:D2").Value = Array("Supplier Name", "Cheque Name", "Amount", "Curr") End If LastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row ColG = Application.Transpose(WS.Range("G2:G" & LastRow).Value) ColF = Application.Transpose(WS.Range("F2:F" & LastRow).Value) Set a = New Collection: Set b = New Collection On Error Resume Next For i = 2 To LastRow If ColG(i - 1) <> "" Then a.Add WS.Cells(i, "A").Value, CStr(WS.Cells(i, "A").Value) If ColF(i - 1) <> "" Then b.Add WS.Cells(i, "A").Value, CStr(WS.Cells(i, "A").Value) Next i On Error GoTo 0 n = 3 For Each Kay In a dest.Cells(n, "A").Value = Kay dest.Cells(n, "C").Value = Application.WorksheetFunction.SumIf _ (WS.Range("A2:A" & LastRow), Kay, WS.Range("G2:G" & LastRow)) dest.Cells(n, "D").Value = "USD" TotalG = TotalG + dest.Cells(n, "C").Value n = n + 1 Next Kay For Each Kay In b dest.Cells(n, "A").Value = Kay dest.Cells(n, "C").Value = Application.WorksheetFunction.SumIf _ (WS.Range("A2:A" & LastRow), Kay, WS.Range("F2:F" & LastRow)) dest.Cells(n, "D").Value = "EGP" TotalF = TotalF + dest.Cells(n, "C").Value n = n + 1 Next Kay totals = Array("Total USD", TotalG, "Total EGP", TotalF) n = n + 1 j = Array("USD", "EGP") For i = LBound(totals) To UBound(totals) Step 2 dest.Cells(n + (i / 2), "A").Value = totals(i) dest.Cells(n + (i / 2), "C").Value = totals(i + 1) dest.Cells(n + (i / 2), "D").Value = j(i / 2) Next i For i = 3 To n - 1 dest.Cells(i, "C").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" Next i Irow = n + (UBound(totals) \ 2) Set tbl = dest.ListObjects.Add(xlSrcRange, dest.Range("A2:D" & Irow), , xlYes) tbl.Name = "ResultsTable" tbl.TableStyle = "TableStyleLight19" For i = Irow - 2 To Irow - 1 With tbl.Range.Rows(i).Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlMedium End With Next i Set rng = dest.Range("D3:D" & n - 1) With rng.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""EGP""") .Interior.Color = RGB(255, 192, 203) .Font.Color = RGB(255, 0, 0) End With With tbl.Range.Columns("B:D") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End If End Sub Suppliers VBA .xlsb

بداية يجب تفعيل هذه المكتبات لديك ..... KAN-picutre.rar

انت دائما مبدع وفنان كعادتك تبهرني بابداعك الف شكر 🌹🌹🌹🌹🌹🌹🌹🌹

لم تعمل عندي لان بسبب النظام 64 سوف الغي علامت الاعجاب 😕

تفضل جرب هدا Private Sub CommandButton1_Click() Dim ws As Worksheet, src As Range, i As Long Dim arr() As Variant, columns() As Variant Dim Code As String, lastrow As Long, exists As Long Set ws = Sheets("التكويد") lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Code = Me.TextBox4.Value If Code = "" Then: MsgBox "الرجاء إدخال كود الصنف", vbExclamation, "خطأ": Exit Sub exists = WorksheetFunction.CountIf(ws.Range("a2:a" & lastrow), Code) If exists > 0 Then: MsgBox "كود الصنف موجود مسبقا", vbExclamation, "إنتبـــاه": Me.TextBox4.Value = "": Exit Sub With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set src = ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0) columns = Array("A", "B", "C", "D", "F", "G", "H") arr = Array(Me.TextBox4.Value, Me.TextBox1.Value, Me.TextBox7.Value, Me.TextBox2.Value, _ Me.TextBox3.Value, Me.TextBox5.Value, Me.TextBox6.Value) For i = LBound(arr) To UBound(arr) If i <= UBound(columns) Then ws.Cells(src.Row, columns(i)).Value = arr(i) End If Next i For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" End If Next ctrl With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With MsgBox "تم إدخال البيانات بنجاح", vbInformation, "نجاح" End Sub عدم تكرار .xlsm

وعليكم السلام ورحمة الله كما ترى اخي الكريم قمت بتصميم يوزرفورم واضفت له اكواد vba بسيطة جدا اما بالنسبة لطلبك يمكنك انشاء زر على اي ورقة عمل وربطه بهذا الماكرو Sub show_form() UserForm1.Show End Sub