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

وهذه تجربتي 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 مستخدم هذا الرد ربما يفيدك

السلام عليكم ورحمة الله تعالى وبركاته اساتذتى الكرام فى المرفق الاتى استخدم هذا الكود Me.txtxname.ControlSource = "=IIf([xname] Is Null, Null, " & "Replace([xname], """ & FindAsType & """, """ & strTagStart & FindAsType & strTagEnd & """))" حيث أن txtxname هو مربع نص غير منضم ومصدر بيانات هذا المربع هو الحقل xname اريد عمل هذا الكود فى روتين عام حتى يتم استخدامه لاى عنصر اخر مع تبديل المتغير الذى يدل عليه انا حاولت ان اكتب الروتين بهذا الشكل Public Function StrHighLight(ByVal strFieldName As String, ByVal FindAsType) As String StrHighLight = "=IIf(strFieldName Is Null, Null, " & "Replace(strFieldName, """ & FindAsType & """, """ & strTagStart & FindAsType & strTagEnd & """))" End Function لاستدعاءه بتلك الطريقة Me.txtxname.ControlSource = StrHighLight(xname, FindAsType) سطر الكود يعمل عند استخدام مربع النص الحاص بالبحث ذو اللون الاصفر ولكن لم تفلح هل من مساعدة فى كتابة الروتين الذى يقول بنلك العملية ام انه لا يمكن تحقيق ذلك ؟! Filter With More Condition.mdb

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

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

الحل Hani.xls

Private Const GWL_STYLE = -16& Private Const TVM_SETBKCOLOR = 4381& Private Const TVM_GETBKCOLOR = 4383& Private Const TVS_HASLINES = 2& Private Const CLR_INVALID = &HFFFF Private Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Declare Function GetWindowLong Lib "user32" _ Alias "GetWindowLongA" _ (ByVal hwnd As Long, _ ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function OleTranslateColor Lib "oleaut32" _ (ByVal clr As OLE_COLOR, _ ByVal hPal As Long, _ dwRGB As Long) As Long Private Function TranslateColor(ByVal clrColor As OLE_COLOR, _ Optional hPalette As Long = 0) As Long If OleTranslateColor(clrColor, hPalette, TranslateColor) Then TranslateColor = CLR_INVALID End If End Function Private Sub ChangeBackgroundColor(ByVal hwnd As Long, ByVal longColor As Long) Dim longStyle As Long SendMessage hwnd, TVM_SETBKCOLOR, 0, ByVal TranslateColor(longColor) longStyle = GetWindowLong(hwnd, GWL_STYLE) SetWindowLong hwnd, GWL_STYLE, _ longStyle And (Not TVS_HASLINES) SetWindowLong hwnd, GWL_STYLE, longStyle End Sub Private Sub Form_Load() ChangeBackgroundColor axTreeView.hwnd, 14935260 ' axTreeView is me.axTreeView End Sub

السلام عليكم ورحمة الله وبركاته .. تفضل اخوي العزيز .. غير فقط العدد .. عند 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

فكرت اكتب الروتين بهذا الشكل 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

السلام عليكم استاذ ابا جودى المشكلة عندي هي ان النظام يحتوي على صوت واحد فقط لذا قمت بتنزيل صوت ثاني وتم حل المشكلة اعتقد ان المشكلة اعلاه هي عدم وجود صوت ثاني او عدم وجود اي صوت وبعض الانظمة لا تحتوي البرنامج الذي يقرا النصوص والله العالم ملاحظة : تم استخدام البرنامج ادناه لتنزيل الاصوات المختلفة وبعدة لغات 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

تم تعديل الكود ليعطي حصص كل استاذ منفرداً جسب الأيام والصف والتوقيت Option Explicit Sub find_Prof() Dim A, i%, X% Dim First_Address$, Current_Address$ Dim F_rg As Range Dim Optional_rg As Range Dim Plage_E As Range, Plage_F As Range Dim Plage_G As Range, Plage_H As Range Dim Plage_I As Range, Plage_Match As Range Dim Ak As Worksheet, Pr As Worksheet Dim Clas$ Set Ak = Sheets("Akssam") Set Pr = Sheets("Prof") Pr.Range("E8:I84").ClearContents A = Array("محمود", "علي", "مصطفى", "عمر", "نورة", "عدي", "زيد") For i = 0 To UBound(A) Set Plage_Match = Pr.Range("D8:D18").Offset(i * 11) Set Plage_E = Pr.Range("E8:E18").Offset(i * 11) Set Plage_F = Pr.Range("F8:F18").Offset(i * 11) Set Plage_G = Pr.Range("G8:G18").Offset(i * 11) Set Plage_H = Pr.Range("H8:H18").Offset(i * 11) Set Plage_I = Pr.Range("I8:I18").Offset(i * 11) Set F_rg = Ak.Range("D8:M29").Find(A(i), lookat:=1) If Not F_rg Is Nothing Then First_Address = F_rg.Address Current_Address = First_Address 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: Set Optional_rg = Plage_E Case 7: Set Optional_rg = Plage_F Case 9: Set Optional_rg = Plage_G Case 11: Set Optional_rg = Plage_H Case 13: Set Optional_rg = Plage_I End Select X = Application.Match(Ak.Cells(F_rg.Row, 3), Plage_Match, 0) Optional_rg.Cells(X) = F_rg & " / " & F_rg.Offset(, -1) _ & ": " & Clas Set F_rg = Ak.Range("D8:M29").FindNext(F_rg) Current_Address = F_rg.Address If First_Address = Current_Address Then Exit Do Loop End If 'for F_rg Next i End Sub الملف مرفق (عسى ان ينال الإعجاب) allaoua_Super.xlsm

جرب هذا الكود 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

السلام عليكم و رحمة الله وبركاته اسعد الله ايمكم بكل خير اشتقت لكم جميعا بارك الله فيكم اخي الكريم يتم تسمية نطاق البيانات بـ Data_001 ثم يتم استخدام الدالة =SUMPRODUCT((INDEX(Data_001;0;1)=$C$2)*(INDEX(Data_001;0;2)=$D$2);INDEX(Data_001;0;MATCH($D6;INDEX(Data_001;1;0);0))) كما في المرفق جلب البيانات بشروط افقية وراسية.rar

بعد اذن اخي ياسر ربما يكون المطلوب في هذا الملف (مرفق للتجربة) الكود : 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