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

كثير من تصاميم HTML نتمنى ان تكون موجودة في الاكسس و ربما يصبح الحلم حقيقة عما قريب اضع بين يديكم فكرة ! فكرة جدول مبني بلغة HTML مع تلوين الاسطر عند المرور عليها آمل ان تنال على استحسانكم web.mdb

وعليكم السلام المرفق لعل فيه ما تريد... بتحفظ بالنسبة للقيمة المستقبلية حيث جعلتها تساوي "القيمة الأولية + الربح عليها" (باستعمال نسبة الربح) ملف.xlsx

تفضل اخي سعد حاولت قدر الامكان تنفيد المطلوب لاكن بطريقة مختلفة اتمنى ان تستفيد منها مع بعض الاظافات البسيطة في انتظار الرد بعد التجربة sella v4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد فهمت طلبك بشكل صحيح =INDEX($I$3:$I$6;MATCH(C2;$H$3:$H$6);1) v2 ملف.xlsx

Function circle5(dr As Range) Dim OvName As String OvName = "ty" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(0, 102, 204) .Fill.Transparency = 0 End With End Function Function circle2(dr As Range) Dim OvName As String OvName = "mh" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(255, 0, 0) .Fill.Transparency = 0 End With End Function Function circle1(dr As Range) Dim OvName As String OvName = "st" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(255, 255, 0) .Fill.Transparency = 0 End With End Function Function circle3(dr As Range) Dim OvName As String OvName = "shp" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(0, 176, 80) .Fill.Transparency = 0 End With End Function Sub Select_Shape() Call رسم_4_الدوائر Call رسم_5_الدوائر Call رسم_6_الدوائر Call رسم_7_الدوائر End Sub Sub رسم_4_الدوائر() Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "ازرق" Then circle5 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "ازرق" Then circle5 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "ازرق" Then circle5 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "ازرق" Then circle5 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "ازرق" Then circle5 Cells(r, "g") End If Next r r = 0 For r = 5 To 123 If Cells(r, "h") = "ازرق" Then circle5 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "ازرق" Then circle5 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "ty*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 102, 204) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub Sub رسم_5_الدوائر() Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "اصفر" Then circle1 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "اصفر" Then circle1 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "اصفر" Then circle1 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "اصفر" Then circle1 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "اصفر" Then circle1 Cells(r, "g") End If Next r r = 0 ' عين For r = 5 To 123 If Cells(r, "h") = "اصفر" Then circle1 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "اصفر" Then circle1 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "st*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 255, 0) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub Sub رسم_6_الدوائر() 'احمر Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "احمر" Then circle2 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "احمر" Then circle2 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "احمر" Then circle2 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "احمر" Then circle2 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "احمر" Then circle2 Cells(r, "g") End If Next r r = 0 For r = 5 To 123 If Cells(r, "h") = "احمر" Then circle2 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "احمر" Then circle2 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "mh*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub Sub رسم_7_الدوائر() 'اخضر Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "اخضر" Then circle3 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "اخضر" Then circle3 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "اخضر" Then circle3 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "اخضر" Then circle3 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "اخضر" Then circle3 Cells(r, "g") End If Next r r = 0 For r = 5 To 123 If Cells(r, "h") = "اخضر" Then circle3 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "اخضر" Then circle3 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "shp*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 176, 80) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub تم الحل شكرا خااااااااااااااااالص

أستاذ وائل هذا تصوري لما فهمت عند فورمين راجعهم وراجغ المرفق جيداً ... ورد بالذي تريده . DDWaael.Accdb

السلام عليكم ورحمه الله وبركاته وبها نبدأ استاذنا الفاضل @محمدي عبد السميع تم اختصار الاكواد الثمانيه الي كود واحد فقط استدعاء بيانات بطريقه الفورمه.xlsb

وفيك بارك اخى لان خط الدوائر ليس هو خط الكتابه الاتنين مختلفين عن بعض وتمت المعالجه سوف يصبح نفس الخط الكود يضع الدوائر حسب الشرط الذي قمت انت بوضعه في الكود وهو اصغر من الخليه B2 وهو الرقم 80 وكل الارقام التى تم وضعها كانت اقل من 80 ضع ارقام فوق ال 80 وستجد انه لا يضع عليه دوائر لو يوجد شروط اخري لوضع الدوائر ناجح او راسب قم بكتابتها بنفسك ستكون سهله ان شاء الله وان استصعب عليك شيء فلا تتردد بالسؤال والطلب فقط قم بفتح موضوع اخر بطلبك الجديد وستجد ما يسرك ان شاء الله circle.xlsm

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

وفيك بارك اخى والحمد لله الذي بنعمته تتم الصالحات

بالفعل الخطأ مني عذرا وبارك الله فيك

أهلا بك أخي @يحي عبد الله 🙂 ببساطة يمكنك عمل استعلام تحديث .. والتحديث سيكون : [حقل تاريخ انتهاء العقد] + 30

ابشر

السلام عليكم اليك الطريقة بعد التعديل على الملف فى صفحة ارقام الجلوس2 Private Sub CommandButton1_Click() Range("e2").Select ActiveCell.FormulaR1C1 = "1" ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do ActiveCell = ActiveCell + 10 ActiveWindow.SelectedSheets.PrintOut If Range("e2").Value >= 20 Then Exit Sub Loop Until ActiveCell.Value = Range("p10").Value Range("A1").Select End Sub يرجي وضع الاكواد بين اقواس طباعة_1.xlsm

كبداية فقط Sub test() Dim a With Sheets("sheet1") a = .Range(.Cells(10, 3), .Cells(10, 13).End(xlDown)).Cells End With With Sheets("تقييم") .Cells(13, 3).Resize(UBound(a) - 1).EntireRow.Insert With .Cells(13, 3).Resize(UBound(a), 9) .Value = a With .Resize(, 26).Borders(xlInsideHorizontal) .Weight = xlThin End With End With End With End Sub

Try this formula =IF(C5="","",IF(AND(C5>$A$2,C5<=$B$2)=FALSE,"Not Calculated",IF(COUNTIF($A$5:$A5,A5)>3,"Not Rounded","Calculated")))

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

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

عن طريق تقرير رئيسي وبه تقارير فرعية تكون مربوطة ببعضها البعض عن طريق العلاقات كما قال أخي @Mohameddd200300 ..

تفضل أخي طلبك حسب ما فهمت ورد في أقرب وقت لأني على سفر . t-times-1.accdb

شكرا اخي لكن انتا نسيت اللون الازرق

أفكار جميلة ورائعة بارك الله فيكم جميعا أحبتي ونظرا لأني أهوى اختصار الأكواد والمعادلات يمكنني تعديل المعادلة إلى في A2 =MID(SUBSTITUTE(A$1," ",""),ROW(A1),1) بالتوفيق

=MID(SUBSTITUTE(A$1;" ";"");ROWS(A$2:A2);1)

الحمد لله الذي بنعمته تتم الصالحات

أنا لست المبرمج ولكن ناقل للموضوع .... أدخل على الموضوع السابق وتواصل معه ...

حياك أخي بلال ..... يمكن التواصل مع المبرمج الأخ / حمدي

السلام عليكم هذا اول برنامج اقوم بعمله على الاكسس وهذا العمل تحت اشراف الاساتذه الكبار بهذا الصرح التعليميى الكبير وكنت انوى عرضه بعد تقفيله ولن لظروف خاص لم اتمكن من ذلك ولحرصى على ان يستفيد الجميع وليكون مرجع لكل مبتدء مثلى لما به من خلاصه دروس الاساتذه الكبار الذين احبهم فى الله وادعوا المولى عز وجل ان يعطيهم من الخير قدر كرمه البرنامج تم تحت الاشراف المباشر لاستاذى الجيليل أبـوخليل بارك الله فيك وكذلك جميع الاساتذه والاخوه بهذا الصرح الكبير ______________________________- بعض المشكلات التى واجهتنى بالبرنامج: اولا لم اتكمن من حفظ نشخه مقفله منه وتواجهنى هذه الرساله : وكنت فى حيره من امرى ؟ هل اقوم باخفاء الاكسس ام اقوم بعمل قوائم مخصصه على الاكسس اترككم مع بعض الصور student_up.rar