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

السلام عليكم, في السابق كنت استخدم خطوط معينة في برامجي وعند اعطاء البرنامج للعميل لاتظهر الخطوط التي قمت باستخدامها بل يظهر بمكانها الخط ( Arial ) وهذه مُشكلة. كت في وقتها الجأ الى ان اضع الخط بجانب قاعدة البيانات وفي داخل قاعدة البيانات اقوم بعمل تحقق لمجلد Fonts والبحث عن الخط في بداية تشغيل القاعدة, فإن لم يجده يعي رسالة للعميل بان الط مفقود وعليه ان يقوم بتثبيته من جانب البرنامج. بحثت طويلاً في الانترنت عن تثبيت خط من الاكسس فقط بدون مساعدة عامل خارجي ولكن لم اصل لنتيجة. اليوم بحمد الله قمت بحل المشكلة بإستخدام ( Visual .NET ) قمت بكتابة اداة بسيطة وظيفتها تثبيت الخط. يتم تمرير براميتر لها وهي بدورها ستقوم بتثبيته الدوال المستخدمة: AddFontResource CreateScalableFontResource ShellExecuteA للمزيد من المعلومات ، اضغط على اسم الدالة ارفقت لكم المصادر من MSDN شرح بسيط لمن لم يعرف ماذا اقصد بتثبيت الخط واستخدام الخط وانه لن يظهر في حال كان العميل لا يملكه. قمت بارفاق قاعدة بيانات لكم كـ مثال للشرح مع الخط المستخدم مع الاداة. شرح الاستعمال: يجب ان تكون الاداة ( SEMO_RegisterFont.exe ) هي والخط الذي سوف تستخدمه بجانب قاعدة البيانات. افتح برنامجك وضع فيه هذا الاجراء. Sub RegisterFont(nFont) Dim strExe As String Dim strArg As String strExe = CurrentProject.Path & "\" & "SEMO_RegisterFont.exe" strArg = "/SEMO/" & nFont ShellExecute 0, "runas", strExe, strArg, vbNullString, SW_SHOWNORMAL End Sub في الاستدعاء اي في الحدث Form_Current RegisterFont "DroidSansArabic.ttf" حيث ان الـ DroidSansArabic.ttf هو اسم الخط الذي قمنا بوضعه بجانب قاعدة البيانات ملاحظة مهمة جدا: في حال كان اسم الخط يتكون من اكثر من كلمة مثل ( Droid Sans Arabic.ttf ) قم بحذف المسافات بين كلمة واخرى بحيث يصبح ( DroidSansArabic.tts ) وستعمل قاعدة البيانات التي قمت بتصميمها بشكل رائع وبالخطوط التي قمت انت بأختيارها بدون الخوف من مشكلة عدم توفر الخطوط في جهاز العميل. الشرح حصري للمنتدى وغير موجود في الانترنت. لا تشكرني الا اذا وجدت انني استحق ذلك. تم بحمد الله حسنين RegisterFont_SEMO_Pa3x.rar

السلام عليكم اضع بين ايديكم نموذج يحتوي على ساعة رقمية لمعرفة الطريقة ادخل على الاكواد ساعة رقمية.accdb

أرفق اليكم نموذج بحث متعدد النتائج .. به وحدة نمطية بسيطة لتوحديد الأحرف المتشابهة وإزالة المسافات وتجاهل الهمزات والتشكيل ..عسى يجد من ينتفع به.وتجدر الإشارة أن أغلبه من أفكار رواد هذا المنتدى العزيز. أعزكم الله .. تحياتى Officna.rar

وعليكم السلام 🙂 حياك الله 🙂 الموضوع ممكن يُثبت ، ولكن لفترة !! طيب ، لوسمحت تعمل لنا هذه الخدمة: اضف مشاركة هنا ، تشرح فيها سؤالك من جديد ، وبدقة ، وبالكلمات المناسبة ، وانا سوف اضيفها الى سؤالك الاصل ، وبهذه الطريقة ، لما احد الاعضاء يقوم بالبحث عن مثل موضوعك ، يستطيع الوصول اليه بسبب كلماتك وشرحك 🙂 جعفر

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

السلام عليكم اخي الكريم حاتم مشكور على كلماتك الطيبه هذه تعديلات على حدث Private Sub TextBox1000_Change() Private Sub TextBox1000_Change() If TextBox1000.Value = "" Then ListBox1.Clear: Exit Sub Dim x As Worksheet Dim c As Range ListBox1.Clear k = 0 For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 10).End(xlUp).Row For Each c In x.Range("D10:D" & SS) b = InStr(c, TextBox1000) If Trim(c) Like TextBox1000 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 4) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row k = k + 1 End If Next c Next x End Sub وحدث Private Sub ListBox1_Click() Private Sub ListBox1_Click() For I = 0 To ListBox1.ListCount If ListBox1.Selected(I) = True Then For j = 1 To 32 Controls("TextBox" & j).Text = Sheets(ListBox1.List(I, 1)).Cells(ListBox1.List(I, 2), j) Next j r = ListBox1.List(I, 1) Exit For End If Next I End Sub ان شاء الله يعمل معك كما ترجو تحياتي

السلام عليكم اهل المنتدى الكرام أقدم اليكم برنامج : لجميع الانشطة ( تجارى – صناعى – خدمى – مقاولات ) مطابق تمام لمعايير المحاسبة الدولية كافة المعاملات ( حسابات ختامية – مراقبة مخازن – عملاء – موردين – شئون عاملين – استيراد – تصدير – مستخلصات – مراكز تكلفة – خطوط انتاج – مقايسات - باركود) يشمل البرنامج :- - حسابات الاستاذ كاملة وموازين المراجعة والارباح والخسائر والمركز المالى - تكاليف العمليات وتحليل تكاليف المشروعات وبنود الاعمال بشكل تفصيلى واجمالى - مستخلصات المشروعات - الايرادات - ومستخلصات مقاولين الباطن - منظومة الاجور والمرتبات بشكل متكامل ويمكن تعديلها حسب قانون الدولة - حسابات ضريبة المبيعات والارباح التجارية والصناعية وضريبة كسب العمل وطباعة الاقرارات الضريبية - مراقبة المخازن ومتابعة كروت الصنف وتسعير المنصرف بثلاثة طرق ( الوارد اولا يصرف اولا – المتوسط المرجح – اخر سعر ) - امكانية قرائة وطباعة الباركود وبدون الحاجة لطابعة خاصة - حسابات النقدية بالصندوق والبنوك وتعدد العملات - تكاليف الاستيراد وحساب تكلفة المشتريات المستوردة - حسابات تكاليف خطوط الانتاج وحساب تكلفة الوحدة من المنتجات - تعدد المستخدمين للبرنامج وصلاحيات خاصة لكل مستخدم وسهولة اضافة وحذف مستخدم وسهولة تعديل الصلاحيات - امكانية اضافة مجموعة شركات داخل البرنامج وكلمة مرور لكل شركة - يصلح البرنامج للعمل فى مصر وفى دول الخليج العربي - البرنامج يشمل روابط شرح تفصيلى لكل اجزائه واسم المستخدم وكلمة السر admin 123 وهذا هو البرنامج: بارك الله فيكم The_fastest.rar

هذه طريقة الخبراء 🙂 جعفر

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

السلام عليكم مع درس جديد وتعلم عمل فورم شريط التقدم Progress Bar ، والذي يستخدم في حالة الأكواد التي تستغرق وقت ليظهر مدى تقدم الكود ، ومرفق مع الملف صور لكيفية ضبط أدوات التحكم على الفورم .. https://www.file-upload.com/p9rtijdjg3ki

جرب هذا الملف الصفجة Facteur الكود Option Explicit Sub get_data() Dim dic As Object Dim dic_key Dim ro# Dim i%: i = 2 Dim x_titel#: x_titel = 2 Dim lrDem# Facteur.Range("H:M").Clear lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row Facteur.Range("Q1") = "رقم الفاتورة" Dim my_rg As Range Set my_rg = Demandes.Range("a1:f" & lrDem) Set dic = CreateObject("scripting.dictionary") With dic Do Until Demandes.Cells(i, 1) = vbNullString If Not .exists(Demandes.Cells(i, 1).Value) Then .Add Demandes.Cells(i, 1).Value, "" End If i = i + 1 Loop For Each dic_key In dic.keys Facteur.Range("H" & x_titel).Resize(8, 2).Value = Range("Header_Rg").Value Range("H" & x_titel + 2).NumberFormat = "0" Facteur.Range("Q2") = dic_key my_rg.AdvancedFilter 2, Facteur.Range("Q1:Q2"), Facteur.Range("H" & x_titel + 9) Range("I" & x_titel + 5) = Range("i" & x_titel + 10) Range("I" & x_titel + 5).NumberFormat = "d/m/YYY" Range("I" & x_titel + 4) = dic_key ro = Facteur.Cells(Rows.Count, "H").End(3).Row Range("M" & ro + 2) = Evaluate("SUM(M" & x_titel + 10 & ":M" & ro & ")") Range("M" & ro + 3).Value = Range("M" & ro + 2) * [D2] / 100 Range("M" & ro + 4).Value = Range("M" & ro + 2) + Range("M" & ro + 3) Range("H" & ro + 2).Resize(3).Value = Range("RESULT").Value x_titel = ro + 8 Next End With dic.RemoveAll: Set my_rg = Nothing Range("Q1:Q2").Clear End Sub '========================= Sub clear_data() Facteur.Range("H:M").Clear End Sub '========================= Tasmim Fatura.xlsm

أحسنت استاذى الكريم بارك الله فيك

بارك الله فيك استاذ عصام وزادك الله من فضله

السلام عليكم مشكورين اخواني عبد اللطيف وابا جودي وهذا التعديل بالعربية وساعة بعقارب Desktop.rar

كل ما فى الموضوع جعلت (taxt_kod) (Control Source) وليس (taxt_kod=) وكذلك(Barcod Type) (Code128) وليس (Code39)

اهلا @محمد احمد لطفى هذا السطر والسطر الأول أيضا كانا من أجل أزرار التبديل التي في الصورة التالية، وبناءً عليه يمكنك حذفهما إن شئت. بالنسبة لبرنامجك أنا لا أعرف آلية العمل فيه! فاعذرني

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

تم التعديل excel analys.xlsx

تفضل معادلة بحث.xlsx

يمكنك استخدام هذه المعادلة في الخلية B1 ويمكنك سحب المعادلة للإسفل =IF(A1="","",A1) New Microsoft Excel Worksheet.xlsx

السلام عليكم هذا مثال لتثبيت الخط داخل الونداوز من داخل ملف الأكسس إضافة خط للونداوز.rar

السلام عليكم تفضل Copy of Investment Plans - Copy.xlsm

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

الصورة لا تنفع اذ لايمكن التعامل مع صورة ولا تنتظر ان يقوم احد من الاساتذة بوضع ملف لك بهذا الحجم حمل قسم من الملف حوالي 20 صف لا أكثر( لوضع الكود المناسب ثم يمكن تعميمه على كامل الملف )مهما كان حجم البيانات

رائع استاذ مصطفى أعتذر لم ارَ ردك على الموضع الا بعد نتزيل ردي انا لكن اقترح ادراح قوائم منسدلة بالاسماء والاكواد دون تكرار (لتفادي خطأ الكتابة مسافة زائدة او غلط املائي الخ....) و توفيراً للوقت

جرب هذه المعادلة لعلها تفى بالغرض =SUMPRODUCT(--(B4:H4<>""))

عليكم السلام عاشت ايدك و بارك الله فيك استاذ عبداللطيف عاشت ايدك وبارك الله فيك استاذ ابا جودي

رائع أستاذ مصطفى بارك الله فيك

كان هناك خطأ لديك في المدي المكتوب بالمعادلة في الخلية F1 وتم التصويب يرجى منك تضبيط المدى في الشكل البياني لأنني ذهاب الآن لعملى excel analys.xlsx

اتفضل الشيت لعله يفى بالغرض نسخة من المصنف1-1.xlsm

يجب عند البحث مسح السابق بالضغط دبل كليك ومفتاح Delete ثم بدأ كتابة البحث مثلاً أنت تبحث اسم محمد فيظهر أول أول اسم في الصف والفرقة ولكن لو كملت اسم الأب ياتي الاسماء التي تبدأ بالاسم واسم الأب وكذلك الحال لو تكرر اسم الأب وكملت كتابة اسم الجد تلاحظ تم التصفية أقل ولو حضرتك كتب أي اسم بالكامل ثم ضغطت بالماوس في أي مكان بالورق لظهر لك الاسم أي أنه يجب بعد تحديد الاسم الوقوف بأي مكان في ورقة العمل

بعد اذن الاستاذ احمد بدرة واثراء للموضوع جرب هذا الملف نسخة من 1.xlsx

وعليكم السلام 🙂 العلاقات عندك تمام ، ولكن عندك كود حقل type النموذج الفرعي "بعد التحديث" كان محتاج تعديل 🙂 جعفر Database1.zip

العفو فكلنا نتعلم فالمنتدى في المقام الأول تعليمي

جرب كده مشكلة في الباركود.accdb

ليس هناك أجمل من الاعتراف بفضل شخص علينا، والأفضل من هذا توجيه رسالة معبّرة مليئة بكلمات شكر وتقدير تعبر عن صدق المشاعر بداخلنا وامتناننا لما يقوم به من أجلنا علينا دائماً أن نشكر ونقدر من قدّموا لنا المساعدة ومدّوا لنا يد العون عند حاجتنا لمن يقف إلى جانبنا، وعلينا أن نبوح لهم دوماً عن فرحنا بوجودهم وتقديرنا لمساندتهم إن المعلم هو كفاية حاجتنا وهو الحقل الذي نزرعه بالمحبة ونحصده بالشكر هو مائدتنا وموقدنا لأننا نأتي إليه جائعين ونسعى وراءه مستدفئين المعلم كنز عظيم يغذينا بالعلم والمعرفة اللازمة ومهما قدمنا للمعلم لن نوفيه حقه فهو رسول العلم والمعرفة وبه قال الشاعر قم للمعلم وفه التبجيلا كاد المعلم أن يكون رسولا، وهنا لكم في هذا المقال عبارات شكر معلمينا فى هذا المنتدي. إن قلتُ شكراً فشكري لن يوفيكم، حقاً سعيتم فكان السّعي مشكوراً، إن جفّ حبري عن التّعبير يكتبكم قلبٌ به صفاء الحبّ تعبيراً. كلمة حبّ و تقدير وتحيّة وفاء وإخلاص، تحيّة ملؤها كلّ معاني الأخوّة والصّداقة، تحيّة من القلب إلى القلب، شكراً من كلّ قلبي رسالة أبعثها مليئة بالحبّ والتّقديروالاحترام، ولو أنّني أوتيت كلّ بلاغة وأفنيت بحر النّطق في النّظم والنّثر لما كنت بعد القول إلّا مُقصّراً ومُعترفاً بالعجز عن واجب الشّكر.

السلام عليكم 🙂 الموضوع كان معقد اكثر مما كنت اعتقد ، وبدأت من جديد اكثر من مرة !! ولكنها خزية تضاف الى شيء اسمه تجربه 🙂 اساس العمل هو استعلام Crosstab ، سهل عمله ، ونتائجه مقبولة 🙂 . . . ولكن لأنك اصررت انك تريد طريقة الجدول ، فأكملنا المشوار من هنا ، بالاستفادة من هذا الاستعلام ، وتحويله الى استعلام إلحاقي ، ليلحق البيانات في الجدول Co_to_Row : . جعلت جميع اسماء الحقول بنفس الطريقة ، والاهم ، اني اضفت حقل الرقم التلقائي: . وتكون البيانات هكذا: . ثم يأتي دور هذا الزر الكبير ، ليقوم بتشغيل الوحدة النمطية ، والتي ستقوم بتعديل البيانات في الجدول . وهذه هي الوحدة النمطية اللتي تقوم بالعمل ، وحاولت ان اجزئها ، واضع الشرح فيها : Public Function ReArrang() '1 Dim rstS As DAO.Recordset Dim rstD As DAO.Recordset Dim RCs As Integer Dim i As Integer Dim N As Integer Dim Co As String Dim jo As String Dim arr_Co() As String Dim arr_jo() As String '2 'append the New data to the Table Co_to_Row DoCmd.SetWarnings False DoCmd.OpenQuery "qry_Append_Co_to_Row" DoCmd.SetWarnings True '3 'we have 8 Areas For N = 1 To 8 '4 'make the field names, based on the loop value Co = "Co" & N jo = "jo" & N '5 'get each set (fields CoX and joX) values Set rstS = CurrentDb.OpenRecordset("Select * From Co_to_Row Where " & Co & " IS NOT NULL") rstS.MoveLast: rstS.MoveFirst: RCs = rstS.RecordCount '6 ReDim arr_Co(RCs) ReDim arr_jo(RCs) '7 'fill the array For i = 1 To RCs '8 arr_Co(i) = rstS(Co) 'Co values arr_jo(i) = rstS(jo) 'jo values '9 'Remove this value from the previous Records rstS.Edit rstS(Co) = "" rstS(jo) = "" rstS.Update '10 rstS.MoveNext Next i '11 Set rstD = CurrentDb.OpenRecordset("Select * From Co_to_Row Order By Auto_ID") '12 For i = 1 To RCs '13 'add this value to fill all Records rstD.Edit rstD(Co) = arr_Co(i) rstD(jo) = arr_jo(i) rstD.Update rstD.MoveNext Next i Next N '14 'Delete the Empty Records DoCmd.OpenQuery "qry_Delete_Empty_Records" '15 rstS.Close: Set rstS = Nothing rstD.Close: Set rstD = Nothing MsgBox "Done" End Function . وهذا استعلام حذف السجلات الفارغة: . والنتيجة النهائية للجدول: . جعفر 1045.col_to_raw.mdb.zip

بعد إذن أستاذنا الجليل بن علية ممكن تجرب الكودين لإضافة الدوائر وحذفها بدلاً من الكود السابق مع ملاحظة أن كود إضافة الدوائر يقوم بحذف الدوائر السابقة قبل إضافة الدوائر الجديدة تلقائيًا فبمجرد تشغيله لا تحتاج لتشغيل كود حذف الدوائر Sub دوائر() ' رسم شكل بيضاوى Application.ScreenUpdating = False حذف_دوائر Dim c As Range Dim MyRng As Range, V As Shape Dim x As Integer, G As Integer, r As Integer, d As Integer '================================================ G = 4 r = 15 Set MyRng = Range("E16:O16,E30:O30,E44:O44") '================================================ x = ActiveWindow.Zoom ActiveWindow.Zoom = 100 For Each c In MyRng If Cells(c.Row, G) = 0 Then GoTo 1 If IsNumeric(Cells(r, c.Column)) And Not IsEmpty(Cells(r, c.Column)) And (c.Value < Cells(r, c.Column) Or c.Value = "غ") Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left + 1, c.Top + 1, c.Width - 1, c.Height - 1) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 2 V.Line.Weight = 2 d = d + 1 End If 1 Next ActiveWindow.Zoom = x Application.ScreenUpdating = True End Sub Sub حذف_دوائر() Dim shp As Shape, d As Integer For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete: d = d + 1 Next shp End Sub

هاد احلى clock.rar

مزيد المزيد في هذا الملف مع الشرح الوافي UDF_tekrar 8yab .xlsm

هذا ملف اخر لا يأخذ بعين الاعتبار ما تحتويه الخلايا (فقط ينظر الى الارقام بين 1 و نهاية الشهر) ولا ينظر الى الفواصل اي كانت (فواصل نص * \ / الخ.....) Option Explicit Sub Saerch_date() Dim regex As Object, str As String Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .IgnoreCase = True .Pattern = "([1-3]?\d+)" End With Dim MY_Match, x%, s$, i%, m%: m = 1 Dim Days_num$, Final_Month% Dim my_array() Dim arr_arab(1 To 7) arr_arab(1) = "الأحد": arr_arab(2) = "الإثنين" arr_arab(3) = "الثلاثاء": arr_arab(4) = "الأربعاء" arr_arab(5) = "الخميس": arr_arab(6) = "الجمعة" arr_arab(7) = "السّبت" Range("E5:E16,G5:G16").ClearContents For i = 5 To 16 Set MY_Match = regex.Execute(Range("c" & i)) If MY_Match.Count = 0 Then GoTo next_i For x = MY_Match.Count - 1 To 0 Step -1 Final_Month = Month(DateSerial([E2], i - 4, MY_Match(x))) If Final_Month = i - 4 Then Days_num = Weekday(DateSerial([E2], i - 4, MY_Match(x))) ReDim Preserve my_array(1 To m) my_array(m) = arr_arab(Days_num) m = m + 1 End If Next x Range("E" & i) = m - 1 s = Join(my_array, ",") Range("G" & i) = s s = "": m = 1: Erase my_array next_i: Next Set regex = Nothing Erase arr_arab End Sub الملف مرفق khairi ali_Extra.xlsm

2- استعلام Crosstab يقدر ان يقوم مقام الجدول ، واذا فهمت قصدك صح في قولك: لا يتم تحديثه بشكل تلقائي ، فقصدك اسماء الاعمدة تزيد وتنقص حسب البيانات الموجودة ، مما يعطيك اخطاء في التقرير ، لذا انصحك قراءة هذا الرابط لأن فيه الحل (حقول ثابته ، كما في الجدول) : كلامي عن Column Heading ، واذا عندك معيار في الاستعلام ، فيجب النظر في Parameters كذلك : . . . 1- ولو اني لا انصح بالقيام بعمل جدول مؤقت (لأنه يزيد من حجم قاعدة البيانات , لا ترجع قاعدة البيانات الى حجمها الطبيعي إلا بعد الضغط والاصلاح) ، ولكن اذا كان كلا ولابد ، فرجاء ارفق الجدول النهائي بجميع اسماء الجهات ، 3- ما كان قصدي ربط بين الاكسس والاكسل ، وانما مجرد تصدير ملف من الاكسس الى مجلد ، ومنه يقرأه الاكسل 🙂 وبغض النظر اي طريق اردت ان تأخذ ، فمحتاجين بيانات اكثر ، وخصوصا عدد الجهات يكون صحيح 🙂 جعفر

وعليكم السلام 🙂 ولكن السؤال هنا ، كم حقل تريد في الجدول الجديد؟ هل يعني انك كلما زادت عندك المواد ، تزيد عدد الحقول في الجدول برمجيا؟ طبعا ممكن ، ولكن هذه ليست الطريقة الصحيحة في عمل جداول قواعد البيانات ، والطريقة الصحيحة هي التي عملتها في جدولك ، هكذا . والطريقة الصحيحة لحل مشكلتك هي استعلام Crosstab 🙂 وسؤالي هنا ، ليش ما تريد تستعمل Crosstab ، صحيح له عيوبه ، ولكن له ميزاته كذلك 🙂 الاختيار الآخر اللي يجي في بالي ، هو تصدير البيانات بالطريقة اللي تريدها الى الاكسل بصيغة csv مثلا 🙂 جعفر

جرب التعديل التالي في الكود Sub Goal_Seek_Tax() Dim Opt_a, Opt_b, Opt_c, T As Integer, I As Integer Dim A As Single, B As Single, C As Single Application.ScreenUpdating = False Range("D10:F14").ClearContents For I = 10 To 14 Range("E" & I).Formula = "=(C" & I & "-D" & I & "*5%-F" & I & "*25%)/10%" For T = Int(Range("B" & I).Value / 2) To Range("B" & I).Value Range("D" & I).Value = T Range("G" & I).GoalSeek Goal:=1, ChangingCell:=Range("F" & I) A = Round(Range("D" & I).Value, 2) B = Round(Range("E" & I).Value, 2) C = Round(Range("F" & I).Value, 2) If A > 0 And B > 0 And C > 0 And A = Int(A) And B = Int(B) And C = Int(C) Then A = Range("D" & I).Value B = Range("E" & I).Value C = Range("F" & I).Value GoTo 10 End If Next T 10 If B < 0 Then Range("D" & I).Value = Int(Range("B" & I).Value / 4) Range("G" & I).GoalSeek Goal:=1, ChangingCell:=Range("F" & I) A = Round(Range("D" & I).Value, 2) B = Round(Range("E" & I).Value, 2) C = Round(Range("F" & I).Value, 2) End If Range("D" & I).Value = A Range("E" & I).Value = B Range("F" & I).Value = C Next I Application.ScreenUpdating = True End Sub أرجو أن يفي بالغرض إن شاء الله