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

جرب هذا الملف يحتوي على 3 أكواد ( الكود الأول لتعريف المتغيرات الكود الثاني يقوم باضافة اسماء المرضى الثّالث للفواتير) الأكواد الثلاثة تعمل معاَ بالضغط على الزر "Give Data" Option Explicit Global D As Worksheet Global LrR%, m%, i% Global R As Worksheet '+++++++++++++++++++++++++ Sub Debut() ' Code #1 Set D = Sheets("Dr_Repport") Set R = Sheets("Repport") LrR = R.Cells(Rows.Count, 2).End(3).Row End Sub '++++++++++++++++++++ Sub Uniqe_Malade() Debut ' Code #2 If LrR < 5 Then Exit Sub D.Range("A8:b8").Resize(1000).ClearContents m = 8 For i = 5 To LrR If Application.CountIf(R.Range("B5:B" & i), R.Range("B" & i)) = 1 Then D.Cells(m, 2) = R.Range("B" & i) D.Cells(m, 1) = m - 7 m = m + 1 End If Next End Sub '+++++++++++++++++++ Sub Doctors_Facture() ' Code #3 Rem Created by Salim Hasbaya On 23/10/2020 Uniqe_Malade Dim k%, RoR%, RoD%, x%, t% Dim all#, y% Dim arr(1 To 4) RoR = R.Cells(Rows.Count, 2).End(3).Row If RoR < 5 Then Exit Sub RoD = D.Cells(Rows.Count, 2).End(3).Row If RoD < 8 Then Exit Sub arr(1) = "دكتور حاتم": arr(2) = "دكتور احمد" arr(3) = "دكتورة رانيا": arr(4) = "دكتور محمد" D.Range("C8:N1000").ClearContents For k = 1 To 4 y = 8 For t = 8 To RoD For x = 5 To RoR If R.Cells(x, "i") = arr(k) _ And R.Cells(x, "B") = D.Cells(t, 2) Then all = all + IIf(IsNumeric(R.Cells(x, "H")), _ R.Cells(x, "H"), 0) End If Next x With D.Cells(y, 3 * k) .Value = all .Offset(, 1) = Round(all * 0.4, 2) .Offset(, 2) = Round(all * 0.6, 2) End With all = 0: y = y + 1 Next t Next k End Sub الملف مرفق Adb_naser.xlsm

كشف 12 للصف السادس الابتدائي ------------------------------------------------------ ------------------------------------------------------ ------------------------------------------------------ https://cutt.ly/thychh

مشاركة مع حبيبنا الاستاذ . حسام استبدل الكود بهذا >>>>>> If Me.m1.ListCount = 0 Then Me.m1.AddItem "م" & ";" & "الصنف" & ";" & "عدد" & ";" & "المبلغ" Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount Else Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount End If Dim i As Long, SumTotal As Long SumTotal = 0 For i = 1 To (Me.m1.ListCount - 1) SumTotal = SumTotal + Nz(Me.m1.ItemData(i), 0) Next i txtTotal = SumTotal

أعمال ممتازة استاذ أحمد جزاك الله كل خير

بارك الله فيك وزادك الله من فضله

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

المنتدى مليئ بهذه الامثلة .... جرب البحث في المنتدى تجد ما يسرك ...

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

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

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

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

اخي الفاضل تم عمل المطلوب كما تريد تم عمل ترقيم تلقائي تم الغاء الاصفار اذا كانت القيم تحتوي على 0 5-5.xlsx

اخي الكريم لك ما طلبت ماعليك هو كتابة الاسماء فقط وستقوم المعادلات بكل شيء 5-1.xlsx

تم معالجة الامر لأظهار الفورم اضغط على الزر "CLICK" (يمكنك العمل على الشيت حنى ولو كان اليوزر ظاهراً) 1- تقوم بكنابة الرمز الذي تريد في النكست بوكس الاصفر 2 -تقوم باستدعاء ببانات هذا الرمز الى التكست بوكسات الباقية من خلال الضغط على الزر " استدعاء" 3- تفوم بتعديل ما تريد في التكسن بوكسات 4- تضغط على الزر تعديل 5- بهذا تنتقل البيانات الى المكان المناسب في الشيت الملف مرفق Shible.xlsb

جربت التعديل الخير يقوم بالمطلوب

تفضل التعديل Root-2011.rar

مشاركة مع اساتذتي الاعزاء تفضل التعديل ارجو ان يكون طلبك ملاحظة : التعديل مبني على تعديل استاذ د.كاف يار جزاه الله كل خير Root-2020.rar

بارك الله فيك استاذ محي ولإثراء الموضوع يمكنك استخدام هذه المعادلة المعرفة وهذا هو كودها Function Evals(t As String) As Double Dim c As String, i As Long For i = 1 To Len(t) If Asc(Mid(t, i, 1)) < 58 And Asc(Mid(t, i, 1)) > 41 Then c = c & Mid(t, i, 1) Next Evals = Evaluate(c) End Function ثم تكتب المعادلة بالخلية B2 على النحو التالى : =Evals(A2) سليم1.xlsm

بعد اذن الاخ علي لا يتم الترتيب الا اذا 1-كان هناك بيانات في الأعمدة B / C / D ( الترقيم لا ضرورة له لانه يتم اوتوماتيكياً) 2- تمت الكتابة في اول صف غير فارغ Option Explicit Dim RG As Range, Ro '++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Salim As Range) Set RG = Range("A2").CurrentRegion Ro = RG.Rows.Count With Application .EnableEvents = False .Calculation = xlCalculationManual .ScreenUpdating = False End With If Ro = 1 Then GoTo Bay_Bay If Salim.Row = Ro + 1 And _ Application.CountA(Cells(Salim.Row, 2) _ .Resize(, 3)) = 3 Then RG.Sort Range("D2"), 2, Header:=1 With RG.Offset(1).Resize(Ro - 1) .Columns(1) = Evaluate("row(1:" & Ro - 1 & ")") .HorizontalAlignment = 1 .InsertIndent 1 .Font.Size = 18 .Font.Bold = True .Borders.LineStyle = 1 End With End If Bay_Bay: With Application .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub الملف مرفق Auto_sort.xlsm

وعليكم السلام يمكنك هذا ,بوضع ذلك الكود بحدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("d:d")) Is Nothing Then Range("d1").Sort Key1:=Range("d2"), _ Order1:=xlDescending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom End If End Sub فرز حسب 1الاكبر.xlsm

جرب هذا Book1.xlsm

من فضلك اخى الكريم لا تبخل بنجاح المشاركة فليس هناك وجود لأى مشاركة الا بعد تدعيمها بملف مشروح فيه كل المطلوب بكل دقة والا فكان عليك لزاماً استخدام خاصية البحث بالمنتدى قبل رفع هذه المشاركة طالما انك لم تقم برفع ملف !!! ولا تقول ان المشاركة بسيطة لا تحتاج لكل هذا ... فان كان طلبك بسيط لأستطعت انت بنفسك حله ولا احتجت لمساعدة الأخرين فى حل مشكلتك وتفريج كربتك تفضل هذا الكود Sub Unhide_All_Sheets() Dim ws As Worksheet ActiveWorkbook.Unprotect For Each ws In Worksheets ws.Visible = xlSheetVisible Next End Sub وهذا كود أخر Sub Unhide_All_Sheets_Count() Dim wks As Worksheet Dim count As Integer count = 0 For Each wks In ActiveWorkbook.Worksheets If wks.Visible <> xlSheetVisible Then wks.Visible = xlSheetVisible count = count + 1 End If Next wks If count > 0 Then MsgBox count & " worksheets have been unhidden.", vbOKOnly, "Unhiding worksheets" Else MsgBox "No hidden worksheets have been found.", vbOKOnly, "Unhiding worksheets" End If End Sub وهذا كود ثالث Sub Unhide_Selected_Sheets() Dim wks As Worksheet Dim MsgResult As VbMsgBoxResult For Each wks In ActiveWorkbook.Worksheets If wks.Visible = xlSheetHidden Then MsgResult = MsgBox("Unhide sheet " & wks.Name & "?", vbYesNo, "Unhiding worksheets") If MsgResult = vbYes Then wks.Visible = xlSheetVisible End If Next End Sub وهذا كود رابع Sub Unhide_Sheets_Contain() Dim wks As Worksheet Dim count As Integer count = 0 For Each wks In ActiveWorkbook.Worksheets If (wks.Visible <> xlSheetVisible) And (InStr(wks.Name, "report") > 0) Then wks.Visible = xlSheetVisible count = count + 1 End If Next wks If count > 0 Then MsgBox count & " worksheets have been unhidden.", vbOKOnly, "Unhiding worksheets" Else MsgBox "No hidden worksheets with the specified name have been found.", vbOKOnly, "Unhiding worksheets" End If End Sub اختر منهم ما يناسبك عرفت ان كده اهدار للوقت لأنك لم تقم من البداية برفع الملف فالخطأ عندك ,فالملف لم تقم بوضع اى كود به-تفضل بعد وضع الكود يعمل بكل كفاءة مثال.xlsm

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

الظاهر ان المشكلة عندك في الــ Windows جرب ان تنفذ الماكرو من جهاز اخر او دع احد غيرك يحمل الملف ويجربه

السلام عليكم ورحمة الله ضع هذا فى نهاية الكود السابق Me.Text1 = "" Me.Text2 = "" Me.Text3 = "" Me.Text4 = "" Me.Text5 = "" Me.Text6 = "" ثم قم باضافة هذا الكود Private Sub SpinButton1_Change() Set ws = Sheets("mark") For i = 9 To 1000 If Me.ComboBox1.Value = ws.Cells(i, 3).Value Then Me.SpinButton1.Value = i + 1 Me.ComboBox1.Value = ws.Cells(i + 1, 3).Value Exit For End If Next End Sub

جزاكم الله خير وجعله الله فى ميزان حسناتك

السلام عليكم مبدئيا هذا حل باستعمال دالة مستحدثة (تم تسميتها Reversestr)... في الملف المرفق... 1 (3).xlsm

اتفضل الملف لعله يفى بالغرض النص المقلوب.xlsm

هو بالفعل اخى الكريم ورقة الموظفين هى المصدر الذى يؤخذ منه البيانات وتقبل منى الملف بعد التعديل المطلوب ليوم الجمعة ‏‏الحضور والانصراف معدلة-2.xlsx

السلام عليكم تم تعديل معادلتك في D1 (اختصارها بمعادلة صفيف) باستعمال الدوال INDIRECT و ADDRESS مع إضافة معادلة أخرى في الخلية C1 لجلب رقم صف الخلايا غير الفارغة في النطاق A4:A53 اعتمادا على عنوان الخلية في AD1 (التي يحددها الماكرو تلقائيا في حدث الشيت).. أرجو أن تفي الغرض المطلوب... بن علية حاجي Demand SAID.rar

جرب هذا الحل (واضغط اعجاب) BOOK221 sALIM.rar

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

استاذى الفاضل انظر المرفق هل هو المطلوب دليل محاسبي .zip