ياسر خليل أبو البراء

أخي الفاضل أبو العاصم إليك الملف التالي عله يكون المطوب (وإن كنت أفضل أن تكون الموضوعات مستقلة ) Sub FilterMulipleCriteria() Dim Crit As Variant Dim WkRg As Range With Sheets("Sheet2") Set WkRg = .Range("A5:A" & .Cells(.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible) Dim F As Range Dim I ReDim Crit(1 To WkRg.Cells.Count) I = 1 For Each F In WkRg Crit(I) = Format(F, "@") I = I + 1 Next End With With Sheets("Sheet1") .AutoFilterMode = False .Range("A1:C1").AutoFilter Field:=1, Criteria1:=Crit, Operator:=xlFilterValues End With End Sub تقبل تحياتي Filter By Muliple Criteria Based On Visible Cells Only.rar

تسلم أخي محمد الريفي صوتك واضح جداً والفيديو واضح جداً . ربنا يبارك فيك ويجازيك خير

أخي الفاضل عبد الله الحمد لله أن من عليك بالحل يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي ، لكي يلتفت الأخوة الكرام إلى الموضوعات الأخرى الغير مجابة تقبل تحياتي

وجزيت خيراً مثل ما دعوت أخي المتألق علي الشيخ بارك الله فيك

السلام عليكم ورحمة الله وبركاته إخواني الكرام في موضوع للأخ الحبيب محمد حسن أبو يوسف ، قمت بعمل تصفية للبيانات بناءً على مربع نص ، إلا أنه في مشاركة للأخ الغالي رشراش علي أن الكود لا بعمل مع الأرقام ولا يعطي نتيجة ، كما أن الأخ أحمد أبو زيزو طلب مني شرح خطوات العمل فيما يتعلق بهذا الموضوع رابط الموضوع وبناءً على طلب إخواني ، وهم يدركون أنني لا أتأخر عليهم أبداً أقدم لكم موضوع اليوم فارتأيت (حلوة ارتأيت دي ... ) أن أخصص موضوع لهذا الأمر ، نظراً للطلب عليه ، ونظراً للفائدة المرجوة منه ، حيث أنه يسهل عملية البحث من خلال تصفية البيانات المطلوبة. يعتمد الملف المرفق على مثال بسيط للتطبيق ، تم إدراج مربع نص TextBox من خلال التبويب Developer ثم من Insert اختر مربع نص TextBox من القسم ActiveX Controls والبيانات المراد التعامل معها تبدأ من الخلية C3 وحتى آخر خلية بها بيانات... إليكم إخواني الكود مع شرح مبسط للأسطر عله يفيدكم Private Sub TextBox1_Change() 'يقوم الكود بالبحث في نطاق من خلال مربع نص ، وتصفية النتائج طبقاً للنص المدخل '[Insert] ثم من قائمة [Developer] من خلال التبويب [TextBox] قم بإدراج مربع نص 'ثم قم بإدراجه على ورقة العمل [ActiveX Controls] قم بالنقر على مربع النص الموجود في '-------------------------------------------------------------------------- 'تعريف المتغيرات والثوابت Dim LastRow As Long, RngFiltered As Range, I As Long, Arr Static Rng As Range 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إلغاء الفلترة في ورقة العمل النشطة ActiveSheet.AutoFilterMode = False 'قيمة تظهر كل الصفوف لهذا النطاق [Static] إذا لم يكن للثابت المسمى If Not Rng Is Nothing Then Rng.EntireRow.Hidden = False 'تحديد آخر صف به بيانات في العمود الثالث LastRow = Range("C1000").End(xlUp).Row 'أي الخلية التي تسبق أول البيانات [C2] تعيين قيمة النطاق بداية من الخلية Set Rng = Range("C2:C" & LastRow) 'تعيين قيمة للمتغير من النوع مصفوفة ليساوي كل قيم النطاق Arr = Rng.Value 'إذا كان طول السلسلة النصية في مربع النص أكبر من صفر If Len(TextBox1.Text) > Then 'حلقة تكرارية لصفوف النطاق For I = 1 To UBound(Arr, 1) '[']إذا كان العنصر داخل المصفوفة رقمي يتم وضع علامة If IsNumeric(Arr(I, 1)) Then Arr(I, 1) = "'" & Arr(I, 1) Next I 'قيم النطاق تساوي القيم الجديدة في المصفوفة Rng.Value = Arr 'تصفية النطاق بشرط النص المدخل في مربع النص Rng.AutoFilter Field:=1, Criteria1:="=" & TextBox1.Text & "*" End If 'تعيين المتغير ليساوي الخلايا الظاهرة في النطاق Set RngFiltered = Rng.SpecialCells(xlCellTypeVisible) 'إلغاء الفلترة في ورقة العمل النشطة ActiveSheet.AutoFilterMode = False 'حلقة تكرارية لإعادة الأرقام للحالة الأولى بدون العلامة البادئة For I = 1 To UBound(Arr, 1) If Left(Arr(I, 1), 1) = "'" Then Arr(I, 1) = Mid(Arr(I, 1), 2) End If Next I Rng.Value = Arr 'إخفاء الصفوف للنطاق Rng.EntireRow.Hidden = True 'إظهار الصفوف للنطاق الذي تمت عملية التصفية على أساسه RngFiltered.EntireRow.Hidden = False 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub أترككم مع الملف المرفق .. قوموا بتجربة الملف .. تم إدراج بيانات مختلفة نصوص باللغة العربية وباللغة الإنجليزية وأرقام ... حمل الملف من هنا تقبلوا تحياتي أخوكم ياسر خليل أبو البراء

الأخ الفاضل عبد الله جرب الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Not Intersect(Target, Range("D4")) Is Nothing Then Application.ScreenUpdating = False If Target.Value = "نعم" Then Sheets("1").Visible = True Sheets("2").Visible = True Sheets("3").Visible = True Else Sheets("1").Visible = False Sheets("2").Visible = False Sheets("3").Visible = False End If Application.ScreenUpdating = True End If End Sub تقبل تحياتي Hide Sheets Based On Worksheet Change.rar

الأخ الكريم يامن اطلع على التوجيهات أولاً http://www.officena.net/ib/index.php?showtopic=60147 خصوصاً التوجيه التاسع تقبل تحياتي

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

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

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

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

هو فين الملف ؟

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

أخي الكرم مراد يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي ..طبقاً للتوجيهات

أخي الكريم ارفق الملف واطرح موضوع جديد لكي يقدم الاخوة الأعضاء المساعدة الممكنة

هل إسطوانة الوبندوز بها دعم للغة العربية ..قد تكون حزمة اللغة العربية غير موجودة بها يفضل تحميل ويندوز 7 وتختار في بادية التنصيب Arbic حتى يتم تنصيب اللغة العربية أثناء تحميل الويندوز

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

أخي الكريم يوسف النجار يرجى تغيير اسم الظهور للغة العربية إليك الحل التالي عله يفي بالغرض قم بإدراج الكود التالي في حدث الفورم Private Function IsExcluded(ByVal NMB As Long) As Boolean Dim I As Long, ArrExcluded 'الأعمدة المراد استثنائها من التنسيق كتاريخ 'رقم 1 يعني العمود الثاني ، ورقم 2 يعني العمود الثالث وهكذا '[F] في حالتنا العمود الخامس هو المراد استثناء تنسيقه وهو العمود ArrExcluded = Array(5) IsExcluded = False For I = LBound(ArrExcluded) To UBound(ArrExcluded) If NMB = ArrExcluded(I) Then IsExcluded = True Exit Function End If Next I End Function ثم قم باستبدال السطر التالي If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then بهذا السطر If Not IsNumeric(MyVelue) And IsDate(MyVelue) And Not isExcluded(cc) Then ************************************* وهذا السطر قم باستبداله If IsDate(.Cells(iRow + 1, C)) Then بهذا السطر If IsDate(.Cells(iRow + 1, C)) And Not isExcluded(cc) Then ************************************* وهذا السطر قم باستبداله If tb1 Then بهذا السطر If tb1 And Not isExcluded(C) Then ************************************* وهذا السطر قم باستبداله If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) بهذا السطر If IsDate(MyVelue) And Not isExcluded(C) Then MyVelue = Format(MyVelue, DtF) تقبل تحياتي :fff: Format TextBox As Text Not As Date KH UserForm.rar

أخي الكريم مراد جرب الملف التالي .. =OFFSET($K$1,1,0,MAX($J:$J),1) liste validtion triée sans vides ni doublons 2013.rar

أخي الفاضل مراد تم التنبيه عليك من قبل ولم تستجب لمطلبي يرجى التعامل مع المنتدى طبقاً للتوجيهات اطلع على هذا الرابط http://www.officena.net/ib/index.php?showtopic=60147

الأخ الفاضل عمرو يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي يرجى الالتزام بالتوجيهات تقبل تحياتي

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

أخي أبو سليمان المسميات هامة جداً ..ماذا تقصد بالمجلد ..هل تقصد المجلد أي المجلد أم المجلد تقصد به المصنف رأيي أن تحصل على نتائج لملف واحد الآن حتى يطمئن قلبك أن النتائج صحيحة 100% بعدها يمكنك طرح موضووع جديد وترفق فيه الكود الذي أعجبك وتطلب الإضافة عليه أو تطبيقه على عدد من المصنفات وربنا يكفينا شر المنغصات

أخي الحبيب محمود الفيديو يعمل ..وأنا مجربه

الأخ الحبيب والمعلم الكبير طارق اسمح لي أن أتقدم رغم أنه لا يحق لي التدخل بعد ردك ..إلا أنني كنت قد جهزت الكود ولكن عطلني أنني أردت شرحه للاستفادة منه الأخ الكريم المنار (ربنا يكفيك شر النار وشر الأشرار ويجعلك من المتقين الأبرار) :fff: إليك الملف التالي وإن شاء الله يفي بالغرض Sub SplitWB() 'يقوم الكود بفصل بيانات كل موظف في مصنف جديد مقسم إلى أوراق عمل جديدة '-------------------------------------------------------------------- 'تعريف المتغيرات Dim WB As Workbook Dim Arr Dim I As Long 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'تعيين قيمة للمتغير ليساوي كل القيم في النطاق الحالي في ورقة العمل 'المتغير يخزن البيانات على شكل مصفوفة Arr = ThisWorkbook.Sheets("Sheet1").Cells(1).CurrentRegion.Value 'حلقة تكرارية من الصف الثاني وحتى آخر صف به بيانات 'الحد الأعلى للبعد الأول للمصفوفة ألا وهو بعد الصفوف [UBound(Arr, 1)] حيث يمثل هذا الجزء For I = 2 To UBound(Arr, 1) 'ليساوي المصنف الجديد [WB] تعيين المتغير Set WB = Workbooks.Add 'بدء التعامل مع المصنف الجديد With WB 'إضافة ورقة عمل باسم "ملاحظات" ، ووضع البيانات المرتبطة من العمود التاسع بالمصفوفة With .Sheets.Add .Name = "ملاحظات" .Range("A1") = "ملاحظات" .Range("B1") = Arr(I, 9) .Columns.AutoFit End With 'إضافة ورقة عمل باسم "الأداء والمعلومات المالية" ، ووضع البيانات المرتبطة من العمود الرابع والسابع والثامن بالمصفوفة With .Sheets.Add .Name = "الأداء والمعلومات المالية" .Range("A1").Resize(3, 1) = Application.Transpose(Array("التقييم السنوي", "الراتب", "البدلات")) .Range("B1") = Arr(I, 4) .Range("B2") = Arr(I, 7) .Range("B3") = Arr(I, 8) .Columns.AutoFit End With 'إضافة ورقة عمل باسم "المعلومات الأساسية" ، ووضع البيانات المرتبطة من العمود الأول والثاني والثالث والخامس بالمصفوفة With .Sheets.Add .Name = "المعلومات الأساسية" .Range("A1").Resize(5, 1) = Application.Transpose(Array("اسم الموظف", "تاريخ التعيين", "الجنسية", "الوحدة", "الشعبة")) .Range("B1") = Arr(I, 1) .Range("B2") = Arr(I, 2) .Range("B3") = Arr(I, 3) .Range("B4") = Arr(I, 5) .Range("B5") = Arr(I, 6) .Columns.AutoFit End With 'وهي ورقة عمل افتراضية في أي مصنف جديد [Sheet1] حذف ورقة العمل المسماة .Sheets("Sheet1").Delete 'حفظ المصنف الجديد في نفس مسار المصنف الحالي باسم البيان الموجود في العمود الأول بالمصفوفة .SaveAs ThisWorkbook.Path & "\" & Arr(I, 1) & ".xlsx" 'إغلاق المصنف الجديد الذي تم حفظه .Close End With 'الانتقال لصف جديد والتعامل مع مصنف جديد Next I 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True 'رسالة تفيد بانتهاء عمل الكود MsgBox "Done !", vbInformation End Sub وفي انتظار مساهمتك يا باشمهندس .. زيادة الخير خيرين .. تقبلوا تحياتي :fff: Split Data Into Mulptiple Workbooks YasserKhalil.rar