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

أخي الكريم لا تتم الاستجابة عن طريق معادلة .. حيث أن الكود يتم تنفيذه فقط عند حدوث تغيير في الخلية الهدف أعتقد يوجد طرق للتحايل على هذا الأمر وهو أن تقوم بجعل الخلية الهدف هي الخلية التي يحدث فيه التغيير وليست الخلية التي تظهر فيها نتيجة المعادلة Hide Columns & Rows With Blanks.rar

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

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

أخي الكريم أبو يوسف النجار حسب ما فهمت من طلبك يمكنك ببساطة استخدام المعادلة التالية في الخلية A6 =SUBTOTAL(103, $B$6:B6) قمت بتغيير تنسيق الخلية من نص إلى عام General كما قمت بتفعيل العمليات الحسابية لتكون Automatic يمكنك الآن القيام بالفلترة وسيتم التعامل مع البيانات المفلترة بالتسلسل الصحيح .. أي أن الغرض من المعادلة الحفاظ على عملية التسلسل حتى مع وجود تصفية أرجو أن يكون المطلوب تصفية.rar

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

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

بسم الله ما شاء الله الصيام عامل معاك أحلى شغل .. تسلم وتعيش يا مستر مختار

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

وعليكم السلام أخي الكريم زوهير وكل عام وأنت بخير الفضل لله ثم للأخ الحبيب سليم صاحب المعادلات التي حلت المسألة من الأساس .. فقط أضفت المعادلات داخل سطرين من الكود هذا كل ما قمت به ، فلا ننسى الأخ الرائع المتميز سليم ومشاركته المتميزة والرائعة

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

السلام عليكم يا أمة الله يا بنت الغالي أولاً وقبل كل شيء كبري حجم الخط عشان أنا عيني ضاعت ثانياً فين دعوة إمبارح على الإفطار ؟ ثالثاً طلبك بالشكل ده معقد شوية ... بس والله بتوفيق من الله وأنا خلاص مهيس في آخر اليوم قدرت أوفق بين كل المطلوب رابعاً متنسيش دعوة النهاردة غير دعوة إمبارح خامسا كفاية رغي عشان أنا ريقي ناشف طبيعي سادسا إليكي الكود اللي أنا مش فاهم خلص مني إزاي Sub TransferData_YK() Dim WS As Worksheet Dim strSheet As String, strID As String, strDes As String Dim startDate As Date, endDate As Date Dim LR As Long, lRow As Long, Cell As Range Dim SheetArr, SH As Worksheet, I As Integer Set WS = Sheets("general") strSheet = WS.Range("G1") strID = LCase(WS.Range("B3")) strDes = WS.Range("G2") startDate = WS.Range("B1") endDate = WS.Range("B2") lRow = 6 Application.ScreenUpdating = False WS.Range("B6:G100").ClearContents If strSheet <> "" Then If strDes <> "" Then With Sheets(strSheet) LR = .Cells(Rows.Count, 3).End(xlUp).Row For Each Cell In .Range("E6:E" & LR) If Cell >= startDate And Cell <= endDate And Cell.Offset(, 1) = strDes And LCase(Cell.Offset(, -2)) = strID Then Cell.Offset(, -3).Resize(, 6).Copy WS.Cells(lRow, 2).PasteSpecial xlPasteValues lRow = lRow + 1 End If Next Cell End With Else With Sheets(strSheet) LR = .Cells(Rows.Count, 3).End(xlUp).Row For Each Cell In .Range("E6:E" & LR) If Cell >= startDate And Cell <= endDate And LCase(Cell.Offset(, -2)) = strID Then Cell.Offset(, -3).Resize(, 6).Copy WS.Cells(lRow, 2).PasteSpecial xlPasteValues lRow = lRow + 1 End If Next Cell End With End If Else SheetArr = Array("Shobra", "Maadi", "mohandsen") For I = 0 To UBound(SheetArr) For Each SH In Sheets If SH.Name = SheetArr(I) Then If strDes <> "" Then With SH LR = .Cells(Rows.Count, 3).End(xlUp).Row For Each Cell In .Range("E6:E" & LR) If Cell >= startDate And Cell <= endDate And Cell.Offset(, 1) = strDes And LCase(Cell.Offset(, -2)) = strID Then Cell.Offset(, -3).Resize(, 6).Copy WS.Cells(lRow, 2).PasteSpecial xlPasteValues lRow = lRow + 1 End If Next Cell End With Else With SH LR = .Cells(Rows.Count, 3).End(xlUp).Row For Each Cell In .Range("E6:E" & LR) If Cell >= startDate And Cell <= endDate And LCase(Cell.Offset(, -2)) = strID Then Cell.Offset(, -3).Resize(, 6).Copy WS.Cells(lRow, 2).PasteSpecial xlPasteValues lRow = lRow + 1 End If Next Cell End With End If End If Next SH Next I End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub سابعاً ربنا يسهل وميكونش فيه أي تعقيبات أخرى ومتنسيش تحددي أفضل إجابة ليظهر الموضوع مجاب ومنتهي طبقاً لتوجيهات المنتدى .. وسلم لي على أبو حنين اسنان.rar

الأخ الغالي أكرم جلال إليك الملف التالي Sub HidePicture() '[False] يقوم الكود بإخفاء الصورة باستخدام القيمة '------------------------------------------------ ActiveSheet.Shapes("صورة 1").Visible = False End Sub Sub ShowPicture() '[True] يقوم الكود بإظهار الصورة باستخدام القيمة '------------------------------------------------ ActiveSheet.Shapes("صورة 1").Visible = True End Sub تقبل تحياتي Hide Show Picture.rar

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

أخي وحبيبي في الله محمد الريفي تعجبني ملفاتك بشكل كبير جداً وإعدادها في منتهى الجمال والروعة تسلم وربنا يبارك فيك وكل عام وأنت بخير

أخي الكريم زوهير بناءً على ما تقدم به الرائع المتميز الأخ الحبيب سليم إليك هذا الكود البسيط الي سيؤدي الغرض إن شاء المولى Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$F$2" Or Target.Address = "$G$2" Or Target.Address = "$H$2" Then [I2].Formula = "=SUMIFS(C$3:C$500,$A$3:$A$500,$F$2,$B$3:$B$500,"">=""&$G$2,$B$3:$B$500,""<=""&$H$2)" [J2].Formula = "=SUMIFS(D$3:D$500,$A$3:$A$500,$F$2,$B$3:$B$500,"">=""&$G$2,$B$3:$B$500,""<=""&$H$2)" [K2].Formula = "=SUMIFS(E$3:E$500,$A$3:$A$500,$F$2,$B$3:$B$500,"">=""&$G$2,$B$3:$B$500,""<=""&$H$2)" Range("I2:K2").Value = Range("I2:K2").Value End If End Sub تقبل تحياتي Sum Values Between Two Dates.rar

الأخ الكريم محمود أما آن لك ان تقوم بتغيير اسم الظهور للغة العربية أنا لست متابع للموضوع ولكني قمت ببعض التعديل على الملف الخاص بي الذي أرفقته ليناسب طلبك ليتم تنفي الكود بشكل تلقائي Sub UniqueItems() 'يقوم الكود باستخراج القيم الغير مكررة أي الفريدة وعدها '------------------------------------------------------- 'تعريف المتغيرات Dim R As Range, Cel As Range, LR As Long, D, A 'تحديد آخر خلية بها بيانات في أي عمود LR = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row 'تحديد النطاق المراد العمل عليه واستخراج القيم الفريدة منه Set R = Range("A1:E" & LR) 'تعيين المتغير لتخزين القيم الفريدة داخله Set D = CreateObject("Scripting.Dictionary") 'جملة لتجنب ظهور رسائل خطأ أثناء تنفيذ الكود On Error Resume Next 'مسح محتويات النطاق الذي ستظهر فيه النتائج Range("I2:J500").ClearContents 'حلقة تكرارية لكل خلية داخل خلايا النطاق For Each Cel In R 'إذا لم تكن الخلية قيمتها صفر يتم إضافة العنصر للمتغير المخصص لذلك If Cel <> 0 Then D.Add CStr(Cel), CStr(Cel) Next 'تعيين المتغير ليساوي العناصر الفريدة التي تم تخزينها داخل المتغير الأول A = D.Items 'إظهار النتائج بعد تحويلها إلى شكل رأسي حيث أن المتغير يخزن القيم على شكل مصفوفة Range("I2").Resize(D.Count) = Application.Transpose(A) 'إظهار نتائج عد القيم Range("J2").Resize(D.Count).FormulaR1C1 = "=COUNTIF(R1C1:R100C5,RC[-1])" End Sub تقبل تحياتي Count Unique Items Automatically.rar

جرب معادلة الصفيف التالية =SUMPRODUCT(($D$6:$D$23=$C3)*($E$6:$E$23)*($C$6:$C$23=INDEX(C6:C23,MATCH(1,(SUBTOTAL(3,OFFSET(C6:C23,ROW(C6:C23)-MIN(ROW(C6:C23)),0,1)))*(C6:C23<>""),0)))) لا تنسى أن تضغط Ctrl + Shift + Enter sum.rar

الأخت الفاضلة أمة الله (أبو حنين ) نفس شكل الاسم ونفس شكل الملف الخاص بك .. عموماً تفضل جرب الملف المرفق ..عله يكون المطلوب ... متنساش تدعي لي على الإفطار Sub TransferData_YK() Dim WS As Worksheet Dim strSheet As String, strID As String, strDes As String Dim startDate As Date, endDate As Date Dim LR As Long, lRow As Long, Cell As Range Set WS = Sheets("general") strSheet = WS.Range("G1") strID = LCase(WS.Range("B3")) strDes = WS.Range("G2") startDate = WS.Range("B1") endDate = WS.Range("B2") lRow = 6 Application.ScreenUpdating = False WS.Range("B6:G100").ClearContents If strSheet <> "" Then With Sheets(strSheet) LR = .Cells(Rows.Count, 3).End(xlUp).Row For Each Cell In .Range("E6:E" & LR) If Cell >= startDate And Cell <= endDate And Cell.Offset(, 1) = strDes And LCase(Cell.Offset(, -2)) = strID Then Cell.Offset(, -3).Resize(, 6).Copy WS.Cells(lRow, 2).PasteSpecial xlPasteValues lRow = lRow + 1 End If Next Cell End With End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي اسنان.rar

أخي الكريم يرجى تغيير اسم الظهور للغة العربية إليك الملف التالي رغم أن المطلوب غير واضح ...إذا لم يكن المطلوب ولا أظنه كذلك يرجى التوضيح مع إرفاق النتائج المتوقعة sum.rar

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

بارك الله فيك أخي الحبيب عبد السلام علي على هذه اللفتة الطيبة تقبل الله منا ومنكم صيام وقيام الشهر الكريم :fff:

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

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

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

أخي الحبيب قمت بمراجعة الملف مرة أخرى ووجدت أن النتائج صحيحة ؟؟ لو تكرم أحد الأخوة بمراجعة النتائج وموافاتي بالنتيجة ؟؟؟ هل أدى الملف الغرض أم لم يؤدي ؟ تقبلوا تحياتي