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

وهذه تجربتي Public Function StrHighLight(ByVal strFieldName As String, ByVal FindAsType) As String Dim myStr As String myStr = "=IIf([xname] Is Null, '', " & "Replace([" & strFieldName & "], '" & FindAsType & "', '" & strTagStart & FindAsType & strTagEnd & "'))" 'Debug.Print myStr StrHighLight = myStr End Function ونناديها Me.txtxname.ControlSource = StrHighLight("xname", FindAsType) جعفر وتعديل نهائي Public Function StrHighLight(ByVal strFieldName As String, ByVal FindAsType) As String Dim myStr As String myStr = "=IIf([" & strFieldName & "] Is Null, '', " & "Replace([" & strFieldName & "], '" & FindAsType & "', '" & strTagStart & FindAsType & strTagEnd & "'))" 'Debug.Print myStr StrHighLight = myStr End Function جعفر

طيب ، علشان جوابي يكون مميز ، ممكن برنامجك يشتغل بهذه الطريقة 🙂 لأنك اعلنت في راس الكود عن Dim FindAsType As String فكفاية استعمال Public Function StrHighLight(ByVal strFieldName As String) As String وبالتالي مناداتها تكون Me.txtxname.ControlSource = StrHighLight("xname") جعفر

بردو انت غشيت من الاستاذ جعفر 😛

عند ادخال اي نص او قيمة في الخليتين انقر زر Entr على لوحة المفاتيح وانظر وهذا الكود في حدث شنج Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = ("$F$4") Then Shapes.Range(Array("Rectangle 3")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Target ElseIf Target.Address = ("$F$5") Then Shapes.Range(Array("TextBox 4")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Target End If End Sub ربط مربع نص بدالة.xlsm

سبقتموني في الوصول الى الحل لكني وصلت لنفس نتيجة الاستاذ جعفر بالنهاية وهذا شرف كبير لي 😀 821562509_FilterWithMoreCondition.mdb

السلام عليكم ورحمة الله تفضل LaLiga-2011-2012-V1.5.xls

جزاك الله خيرا اخى واستاذى العزيز @ابا جودى شغل راقى ومزاج عالى بارك الله فيك ونفس الموضوع مع اخى حسام صوت المراه اللى شغال عندى وويندوز 7 واوفيس 2003 و 2016 حزم 32 بت سوف اجرب تنزيل الاصوات كما اشار اخى حسام جزاه الله خيرا

السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز .. Classeur1.xlsx

بمكن الاستغناء غن اليوزر الثاني بهذا الكود 1- عند الضغط غلى الزر تظهر لك رسالة تطلب الكمية (اذا ادخلت بالخطأ نصاُ يبوفف الكود ويطلب عدداً) 2- بعد ادخال العدد المطلوب يقوم الكود بادخال البيانات مع المعادلة المطلوبة الكود Private Sub CmdAdd_Click() If Me.ListFind.ListCount = 0 _ Or Me.ListFind.ListIndex < 1 Then Exit Sub Dim arr() Dim sh As Worksheet Dim Ro%, m%, x%, Y% Set sh = Sheets("فاتورة") Ro = sh.Cells(Rows.Count, "c").End(3).Row If Ro < 10 Then Ro = 9 Ro = Ro + 1 If Ro > 60 Then sh.Range("c10:H60").ClearContents Ro = 10 End If x = Me.ListFind.ListIndex Y = Application.InputBox("tYPE NUMBER", "CHOOSE ONLY NUMBERS", 1, Type:=2) With sh.Cells(Ro, 3) .Value = Val(.Offset(-1)) + 1 .Offset(, 1) = Me.ListFind.List(x, 2) .Offset(, 2) = Me.ListFind.List(x, 3) .Offset(, 3) = Y .Offset(, 4) = Me.ListFind.List(x, 4) End With With sh.Range("h10:h" & Ro) .Formula = "=IF(E10="""","""",PRODUCT(F10:G10))" .Value = .Value End With TextFind_Change End Sub '+++++++++++++++++++++++++++++++++ Private Sub TextFind_Change() ListFind.Clear Dim k#: k = 0 Dim t# Dim laste_row# Dim All_Rg As Range 'Range when we saecrh Dim Fd_Rg As Range 'Range to find Dim F_row#, A_row# 'First row by saerch,Actual row by saerch With Me.ListFind .AddItem "تسلسل" .List(.ListCount - 1, 1) = "رقم الصف" For k = 2 To .ColumnCount .List(.ListCount - 1, k) = Sheets("البيانات").Cells(1, k - 1) Next End With k = 1 With Sheets("البيانات") laste_row = .Cells(Rows.Count, 2).End(3).Row Set All_Rg = .Range("B2:B" & laste_row) Set Fd_Rg = All_Rg.Find(Left(TextFind.Value, Len(TextFind.Value)), lookat:=2) If Not Fd_Rg Is Nothing Then F_row = Fd_Rg.Row: A_row = F_row Do If Left(Fd_Rg, Len(TextFind.Value)) = _ TextFind.Value Then Me.ListFind.AddItem Me.ListFind.List(Me.ListFind.ListCount - 1, 0) = k Me.ListFind.List(Me.ListFind.ListCount - 1, 1) = F_row Me.ListFind.List(Me.ListFind.ListCount - 1, 2) = _ .Cells(F_row, 1) Me.ListFind.List(Me.ListFind.ListCount - 1, 3) = _ .Cells(F_row, 2) Me.ListFind.List(Me.ListFind.ListCount - 1, 4) = _ .Cells(F_row, 3) Me.ListFind.List(Me.ListFind.ListCount - 1, 5) = _ .Cells(F_row, 4) k = k + 1 End If Set Fd_Rg = All_Rg.FindNext(Fd_Rg) F_row = Fd_Rg.Row If F_row = A_row Then Exit Do Loop End If End With If Me.ListFind.ListCount = 1 Then Me.ListFind.Clear End If End Sub الملف مرفق ismail_NEW.xlsm

سلسلة تعليم بور كويري الجزء الأول كيفية إضافة اعمدة بها عمليات حسابية- واضافة عمود بشرط How to use a condition column in Power Query في الفيديو دة تقدر تضيف عمود فيه عمليات حسابية وكمان تقدر تضيف عمود فيه شرط واكثر من شرط https://www.youtube.com/watch?v=PvL9qg7edQA&feature=youtu.be مثال 1 .. بور كويري.rar

اذا قصدك الاكسس لا لكون العدد الاقصي لمستخدمي اكسس 255 ولكن نظام التشغيل ويندوز يسمح في المشاركة لعدد 20 مستخدم فقط اما عند استخدام windows server فيمكن العمل ل 255 مستخدم هذا الرد ربما يفيدك

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

معقولة اقارن اجابتي المتواضعة باجابة بروفيسور 😝

الحل Hani.xls

السلام عليكم ورحمة الله وبركاته .. تفضل اخوي العزيز .. غير فقط العدد .. عند small الخلية (M) و عندTOP الخلية (O) LaLiga-2011-2012-V1.5(2).xls

حلربط مربع نص بدالة1.xlsx

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

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

اخي ابراهيم معادلات رائعة لكن للاسف في جال تكرار الــ Max تظهر نتيجة واحدة ( كما في الصورة) جرب ان تظهر كل النتائج

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

في الواقع المشكلة كانت اني ابحث عن متغير (نفس الشيء كان مع اخوي ابوابراهيم) ، بينما المطلوب كان كتابة الاسم ، وهذا هو الفرق بين : واللي ساعدني على الحل هو طباعة المتغير ، ورؤيته كما يراه الكمبيوتر ، والتعديل عليه حسب الحاجة ، بهذه الطريقة: myStr = "=IIf([" & strFieldName & "] Is Null, '', " & "Replace([" & strFieldName & "], '" & FindAsType & "', '" & strTagStart & FindAsType & strTagEnd & "'))" 'Debug.Print myStr جعفر

عذرا اخى @عبد اللطيف سلوم لم انتبه انه نموذج ادخال تم وقف حدث الحالى جرب الان ووافنى بالنتيجه Dsum2021.accdb

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

وعليكم السلام اتفضل استاذ @عبد اللطيف سلوم ان شاء الله يكون ما تريد تم انشاء اجراء واستدعائه فى حدثى الحالى للنموذج وفى حدث بعد التحديث لحقل اختيار الاسم Sub Dtotal() Me.txtTOTAL = Nz(DSum("Total", "Material", "Cus_Id=" & Me.Cus_Id.Column(0)), 0) Me.txtTAmount = Nz(DSum("Amount", "Res", "Cus_Id=" & Me.Cus_Id.Column(0)), 0) Me.txtRsid = Me.txtTOTAL - Me.txtTAmount End Sub بالتوفيق Dsum2021.accdb

فكرت اكتب الروتين بهذا الشكل Public Function StrHighLight(ByVal strFieldName As String, ByVal FindAsType) As String Dim x As String x = "[" & strFieldName & "]" StrHighLight = " IIf(x Is Null, Null, " & "Replace(x, """ & FindAsType & """, """ & strTagStart & FindAsType & strTagEnd & """))" End Function وتجربة طباعة النتيجة من خلال خلال امر Debug.Print IIf(x Is Null, Null, Replace(x, "م", "<strong><font color=red>م</font></strong>"))

جرب ربما يكون ما تقصد كشف حساب .xlsm

الف شكر اخي الكريم الكود يعمل

انسخ الكود والصقه مكان السابق طبعا بعد اضافة ال فورم 2 و 3 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Application.ScreenUpdating = False On Error Resume Next If Target.Column = 4 Then ' = 4 And Target.Row > 9 Then UserForm4.Show ElseIf Target.Column = 5 Then UserForm3.Show ElseIf Target.Column = 6 Then UserForm2.Show End If End Sub

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

ما رأيك بهذا Sub test() Dim ar As Range Dim sh As Worksheet Dim i As Long For i = 1 To Sheets.Count If Sheets(i).Name <> "TOTAL" Then Set sh = Sheets(i) For Each ar In sh.Cells(3, 3).Resize(26).SpecialCells(xlConstants).Areas ar.Offset(, -1) = ar.Value ar.Value = 0 Next End If Next End Sub ترحيل بيانات من الاجمالي الى السابق.xls

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

فورم شرح كيفية كتابة سورة الاخلاص على الاكسل الفيديو حمل الملف

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

رائع جزاك الله خيرا

بوركت جهودك، و كللت أعمالك جزاك الله خيرا

جميل جدا ابا جود يمكن الآن لصاحب الموضوع الاستفادة من المثال ومن الأكواد المصاحبة لتطوير فكرته

للمرة 100 بعد الالف (عدم ادراج ضفوف كثيرة جداً حوالي 3000 صف ) مثال بسيط من 10 الى 15 صف تكفي الملف كيف يجب ان يبدو في دون الوان فاقعة الصورة يمكن ان تعدل في الكود اذا كان هناك احطاء لاني كنبته على وجه السرعة الكود Private Sub CommandButton1_Click() Dim sh As Worksheet Dim i%, BoL1 As Boolean, BoL2 As Boolean Dim AR_T() Dim AR_C() AR_T = Array(1, 2, 3, 4, 5, 6) AR_C = AR_T For i = 0 To 5 If Me.Controls("TextBox" & AR_T(i)) = "" Then BoL1 = True Exit For End If Next For i = 0 To 5 If Me.Controls("ComboBox" & AR_C(i)) = "" Then BoL2 = True Exit For End If Next If BoL1 Or BoL2 Then MsgBox Prompt:="يجب إكمال كافة البيانات", Title:="خطأ" Exit Sub End If Set sh = Sheets("data") Dim EndRow As Long EndRow = sh.Cells(Rows.Count, "b").End(3).Row + 1 With sh.Cells(EndRow, 1) .Value = EndRow - 1 .Offset(, 1) = TextBox1.Value 'OK .Offset(, 2) = TextBox2.Value .Offset(, 4) = ComboBox1.Value .Offset(, 9) = ComboBox3.Value .Offset(, 10) = ComboBox2.Value .Offset(, 13) = ComboBox4.Value .Offset(, 15) = TextBox6.Value .Offset(, 16) = ComboBox5.Value .Offset(, 17) = TextBox3.Value .Offset(, 18) = TextBox4.Value .Offset(, 19) = TextBox5.Value End With For i = 1 To 6 Me.Controls("TextBox" & i) = "" Me.Controls("ComboBox" & i) = "" Next MsgBox Prompt:="تمت عملية ترحيل البيانات بنجاح", Title:="رسالة تأكيد" End Sub الملف مرفق fATHI.xlsm

سيدي الفاضل ، قلت لك ، واكرر اقول مادمت في اول الطريق في هذا الاتجاه ، فقلتها وأقول لك نصيحة من واحد ابيضّت لحيته في طريق الاكسس : اكتب الرسالة اللي تريدها بالعربي في الجدول ، ثم نادها عن طريقة رقم الرسالة عن طريق الامر Dlookup وانا وضعت لك رابط امثلة استعماله 🙂 طيب و جُزافاً ، هذه الرسالة وعرفت تعملها (او وجدتها في مكان ونسختها) ، فكيف ممكن تعمل بقية رسالئك؟ وللعلم ، فالامر Chr خطأ استعماله للغة العربية ، لأن حدوده 255 ، بينما الصح استعمال ChrW 🙂 وردا على سؤالك : 1. فلما تكتب امر msgbox ، فتلقائيا تأتيك مساعدة الاكسس بإخبارك عن بقية المتغيرات المطلوبة لتكملة الامر ، هكذا: 2. ويمكن استعمال المثال الموجود في مساعد اكسس (انا استعمله دائما ، واحذف الاسطر التي لا اريدها) ، والحصول على بقية الخيارات منه 🙂 . جعفر

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

بالخدمة استاذ ابا جودي نظام التشغيل ويندوز 7 والنواه 64 Bit اضفت المكتبتين لكن نفس المشكلة فقط صوت المراه , صوت المراة مصر ان يحتل المشهد اصل المراه مسيطرة عندي والظاهر ان البرامج عندي تشتغل بنفس برمجتي

بعد إذن أستاذى القدير ومعلمى الجليل الاستاذ @ابو عارف كنت بدأت التجهيز فى طلب الدكتور @حلبي ووجدت مشاركتكم جزاكم الله خيرا اعلم والله كفيتم ووفيتم وهذة فكرتى المتواضعة بما اننى شرعت فى بدأ العمل Filter With More Condition.mdb

الكود كما تريد Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Dim RO% Sub ADD_Sheets() Set T = Sheets("تسجيل_الموظفين") Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 8 Then Exit Sub With T For i = 8 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("B" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("B" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets T.Select Set Flter_rg = T.Range("A7").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name <> T.Name Then Spes_sh.Range("A7").CurrentRegion.Clear Flter_rg.AutoFilter 2, Spes_sh.Name Flter_rg.SpecialCells(12).Copy With Spes_sh.Range("A7") .PasteSpecial (8) .PasteSpecial (12) .PasteSpecial (4) End With RO = Spes_sh.Cells(Rows.Count, 1).End(3).Row If RO > 7 Then Spes_sh.Range("A8").Resize(RO - 7).Value = _ Evaluate("Row(1:" & RO - 7 & ")") End If End If Next Spes_sh T.AutoFilterMode = False T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub الملف لآحر مرة و سوف يغلق الموضوع بعد الرد مباشرة لأنه أخذ ما يزيد من الوقت Hatem_Last.xlsm

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

تفضل أخي Sample filter.accdb

السلام عليكم ورحمة الله وبركاته ممكن تجرب الملف .. الالماني .. الاختصار de .. المعادلة =Translate(A4,"ar","en") translate.xlsm

جرب هذا الملف تم ادراج معلومات عشوائية (يمكن استبدالها بما تريد) تم حماية المعادلات لعدم العبث بها عن طريق الخطأ لا تقم بالترقيم لانه يدرج اوتوماتيكياًعند اكتمال الصف (4 عناصر) من B الى D (حتى 500 صف) Happy.xlsx

جرب هذا الكود 1-دائماً وأبداً تسمية الشيتات باللغة الأجنبية لحسن عمل الكود ونسخه ولصقه والابتعاد قدر الامكان عن الخلايا المدمجة Option Explicit Sub find_Prof() Dim A, itm Dim Ad1$, Ad2$ Dim F_rg As Range Dim Find_what Dim Ak As Worksheet, Pr As Worksheet Dim Clas$ Dim col Set Ak = Sheets("Akssam") Set Pr = Sheets("Prof") Pr.Range("E8:I29").ClearContents A = Array("محمود", "علي", "عمر", "مصطفى") For Each itm In A Set F_rg = Ak.Range("D8:M29").Find(itm, lookat:=1) If Not F_rg Is Nothing Then Ad1 = F_rg.Address: Ad2 = Ad1 Do Select Case F_rg.Row Case Is <= 18: Clas = "4م1 ف1" Case Is <= 19: Clas = "4م1 ف2" End Select Select Case F_rg.Column Case 5: col = 5 Case 7: col = 6 Case 9: col = 7 Case 11: col = 8 Case 13: col = 9 End Select Pr.Cells(F_rg.Row, col) = F_rg & " / " & F_rg.Offset(, -1) _ & ": " & Clas Set F_rg = Ak.Range("D8:M29").FindNext(F_rg) Ad2 = F_rg.Address If Ad1 = Ad2 Then Exit Do Loop End If Next End Sub الملف مرفق allaoua.xlsm

أضافة ماكرو جديد (نفس القديم مع زيادة ما في هذه الصورة) و زر جديد له More Options الملف اصبج بحجم كبير جداً (حوالي 9 ميغا لا يطاق) ما كفاية بقى بحث بهذا الموضوع الذي ضجرنا منه رغبة في مزاجية رب عملك (كل ساعة يلون) سوف يتم اغلاق الموضوع مباشرة بعد الحصول على رد لهذه الاجابة Option Explicit Sub get_By_Color() Dim D As Worksheet Dim Sh As Worksheet Dim Ar(), Min_date As Date, Max_date As Date Dim K%, t%, Arr_sh() Dim My_ro%, m%, ro%, my_sum#, x% Dim Sum_pos#, Sum_Neg# Dim Part_sum# K = 2 Set D = Sheets("DataReport") D.Rows.Hidden = False If D.Range("A3").CurrentRegion.Rows.Count > 1 Then D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear End If If Not IsDate(D.Range("J2")) Or _ Not IsDate(D.Range("K2")) Then Exit Sub Min_date = Application.Min(D.Range("J2:K2")) Max_date = Application.Max(D.Range("J2:K2")) Ar = Array("E", "F", "G", "H", "I", "J") 'For Each Sh In Sheets Select Case UCase(D.Range("N1")) Case 3, 10, 55 For Each Sh In Sheets If Sh.Tab.ColorIndex = D.Range("N1") Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "R_B" For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "R_G" For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 10 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "G_B" For Each Sh In Sheets If Sh.Tab.ColorIndex = 10 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case Else For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 10 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next End Select If m = 0 Then Exit Sub For m = LBound(Arr_sh) To UBound(Arr_sh) D.Cells(K, 1) = Arr_sh(m) D.Cells(K + 1, 1) = "Total " & D.Cells(12, "J") D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20 K = K + 2 Next m My_ro = 3 For m = LBound(Arr_sh) To UBound(Arr_sh) Set Sh = Sheets(Arr_sh(m)) Sh.Range("A5:J20000").Interior.ColorIndex = xlNone ro = Sh.Cells(Rows.Count, 1).End(3).Row For K = LBound(Ar) To UBound(Ar) t = K + 2 For x = 5 To ro If Sh.Cells(x, 1) <= Max_date _ And Sh.Cells(x, 1) >= Min_date Then Sh.Cells(x, 1).Interior.ColorIndex = 40 If Val(Sh.Cells(x, Ar(K))) <> 0 Then my_sum = my_sum + Sh.Cells(x, Ar(K)) '+++++++++++++++++++++++++++++ If Val(Sh.Cells(x, Ar(K))) <= 0 Then Sum_Neg = Sum_Neg + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6 Else Sum_pos = Sum_pos + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 35 End If '++++++++++++++++++++++++++ Part_sum = Round((Sum_pos * 0.85) + Sum_Neg, 2) End If '<>0 End If Next x Select Case D.Cells(12, "J") Case "Positive" Select Case D.Range("N1") Case 3: Sum_pos = 0.1475 * Sum_pos Case 55: Sum_pos = 0.705 * Sum_pos Case Else: Sum_pos = Sum_pos End Select D.Cells(My_ro, t) = Sum_pos Case "Nagative" D.Cells(My_ro, t) = Sum_Neg Case "Part" D.Cells(My_ro, t) = Part_sum Case Else D.Cells(My_ro, t) = my_sum End Select my_sum = 0: Sum_pos = 0: Sum_Neg = 0: Part_sum = 0 Next K My_ro = My_ro + 2 Next m D.Cells(My_ro, 1) = "Sum Of All" Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar With D.Cells(My_ro - 1, 2).Resize(, 6) .Value = D.Cells(1, 2).Resize(, 6).Value .Interior.Color = vbBlue .Font.Color = vbWhite End With D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _ "=Sum(B3:B" & My_ro - 2 & ")" D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6 If D.Range("A3").CurrentRegion.Rows.Count > 1 Then With D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True: .HorizontalAlignment = xlCenter .Value = .Value End With End If For m = My_ro - 2 To 3 Step -1 If D.Cells(m, 1) Like "Total*" And _ Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then D.Range(Cells(m, 1), Cells(m - 1, 1)).EntireRow.Hidden = True End If Next End Sub الملف مرفق Yara_More_Optione.xlsm

بعد اذن اخي ياسر ربما يكون المطلوب في هذا الملف (مرفق للتجربة) الكود : Function No_Repet(inputString As String, Optional delemiter As String = " ") As String Dim inArray() As String Dim xVal As Variant inArray = Split(inputString, delemiter) For Each xVal In inArray If InStr(No_Repet, Trim(xVal)) = 0 Then _ No_Repet = No_Repet & Trim(xVal) & " " Next xVal End Function No_Rrepete.rar

السلام عليكم ضع اى ملف PDF في My Documentsو سمه "Test" Sub test() On Error Resume Next Filename = Range("A1").Value ThisWorkbook.FollowHyperlink "C:\Documents and Settings\User\My Documents\" & Filename & ".pdf" End Sub test1.rar