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

الاخ الفاضل تركي إليك الكود مشروح بالتفصيل Sub YasserKhalil() Dim WS As Worksheet, SH As Worksheet Dim LR As Long, rCell As Range Dim I As Long Dim X As Long, Y As Long 'تعيين أوراق العمل Set WS = Sheets("السرب"): Set SH = Sheets("التمام") 'تحديد رقم آخر صف به بيانات في ورقة العمل المسماة السرب LR = WS.Cells(Rows.Count, "K").End(3).Row 'إلغاء بعض خصائص الإكسيل Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False 'مسح محتويات النطاق الذي ستظهر فيه النتائج المطلوبة SH.Range("B26:V1000").ClearContents 'بدء التعامل مع ورقة العمل المسماة السرب لفلترة البيانات بها With WS 'إلغاء عملية الفلترة إذا كانت موجودة مسبقاً .AutoFilterMode = False 'فلترة نطاق الصف الأول لقاعدة البيانات .Range("A1:K1").AutoFilter End With 'حلقة تكرارية للأعمدة في ورقة العمل المسماة التمام من أول العمود الثالث وحتى العمود الحادي والعشرين For I = 3 To 21 Step 2 'بدء التعامل مع ورقة العمل المسماة السرب مرة أخرى للفلترة ونسخ البيانات المفلترة With WS 'فلترة البيانات في الحقل أو العمود رقم 11 والشرط هو أحد محتويات الصف رقم 24 في ورقة العمل التمام .Range("A1:K1").AutoFilter Field:=11, Criteria1:=SH.Cells(24, I).Value 'نسخ البيانات الظاهرة فقط من العمود الخامس والسادس .Range("E1").Offset(1, 0).Resize(LR, 2).SpecialCells(xlCellTypeVisible).Copy 'لصق البيانات التي تم نسخها إلى الصف رقم 26 في ورقة العمل التمام في العمود المناسب SH.Cells(26, I).PasteSpecial xlPasteValues End With 'الانتقال للعمود التالي في ورقة العمل التمام Next I 'إلغاء عملية الفلترة في ورقة العمل السرب WS.Cells.AutoFilter 'إلغاء خاصية النسخ والقص Application.CutCopyMode = False 'إعادة تفعيل خصائص الإكسيل Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub تم التعامل مع طلبك الثاني ، متنسناش بدعوة تقبل تحياتي AutoFilter Multi Criteria YasserKhalil V2.rar

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

ضع الكود في حدث المصنف Private Sub Workbook_Open() Application.Visible = False UserForm1.Show End Sub

الأخ الفاضل حافظ حافظ لما كل الطلبات في موضوع واحد ..فقط اطرح موضوع جديد بطلب جديد عشان الكل يستفيد .. تقبل تحياتي

الاخ الفاضل إيهاب يرجى اختيار أفضل إجابة ليظهر الموضوع منتهي وأفضل إجابة هي لأخي الغالي بن عليه .. بارك الله فيه وجزاه الله خير الجزاء

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

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

إذاً معادلة الأخ الحبيب بن علية تؤدي الغرض جرب أي رقم في الخلية A1 وضع المعادلة التالية في B1 مثلا =CEILING(A1,0.25) إذا أعطتك المعادلة خطأ غير الفاصلة بفاصلة منقوطة جرب الملف التالي Test.rar

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

الأخ الفاضل أبو زيد أو أبو نبأ لما الدخول بعضويتين للمنتدى ؟ هل تشعر أن أبو نبأ لا يستجيب أحد لموضوعاته فقررت الدخول بعضوية أخرى ..؟؟ مجرد إندهاش شيء آخر تم إزالة أفضل إجابة بعدما قمت بتحديدها .. يعني هو دا رد الجميل !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! إليك الملف التالي .. نسخة محسنة من الكود تقوم بعمل حدود للبيانات التي تم ترحيلها ... Tarhil By AutoFilter YasserKhalil V2.rar

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

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

الأخ الفاضل أبو زيد جرب الملف التالي Sub YasserKhalil() Dim SH As Worksheet Dim LR As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False With Sheets("بيانات") LR = .Cells(Rows.Count, 1).End(3).Row For Each SH In Worksheets If SH.Name <> "بيانات" Then SH.Range("A2:M1000").ClearContents .AutoFilterMode = False .Range("A3:N3").AutoFilter Field:=14, Criteria1:=SH.Name .Range("A3").Offset(1, 0).Resize(LR, 13).SpecialCells(xlCellTypeVisible).Copy SH.Cells(2, 1).PasteSpecial xlPasteValues End If Next SH .Cells.AutoFilter End With Application.CutCopyMode = False Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub تقبل تحياتي Tarhil By AutoFilter YasserKhalil.rar

راجع الرابط التالي http://www.officena.net/ib/index.php?showtopic=55781&hl= تقبل تحياتي

الأخ الكريم طائع الملف ليس له علاقة بعملية الفلترة اطلع على الملف التالي وشوف النتائج ... Sub YasserKhalil() Dim I As Long, X As Long, Y As Long X = 3: Y = 7 Application.ScreenUpdating = False With Sheets("Sheet2") .Range("B7:D17").ClearContents If .Range("A1").Value = 1 Or .Range("A1").Value = 2 Or .Range("A1").Value = 3 Then I = .Range("A1").Value Sheets("data" & I).Activate .Range("B" & Y).Resize(, 3).Value = Cells(109, X).Resize(, 3).Value .Range("B" & Y + 1).Resize(, 3).Value = Cells(109, X + 4).Resize(, 3).Value .Range("B" & Y + 2).Resize(, 3).Value = Cells(109, X + 8).Resize(, 3).Value .Range("B" & Y + 3).Resize(, 3).Value = Cells(109, X + 12).Resize(, 3).Value .Range("B" & Y + 6).Resize(, 3).Value = Cells(109, X + 16).Resize(, 3).Value .Range("B" & Y + 7).Resize(, 3).Value = Cells(109, X + 20).Resize(, 3).Value .Range("B" & Y + 8).Resize(, 3).Value = Cells(109, X + 24).Resize(, 3).Value .Range("B" & Y + 9).Resize(, 3).Value = Cells(109, X + 28).Resize(, 3).Value .Range("B" & Y + 10).Resize(, 3).Value = Cells(109, X + 32).Resize(, 3).Value Else I = .Range("A1").Value Sheets("data" & I).Activate For X = 3 To 43 Step 4 .Range("B" & Y).Resize(, 3).Value = Cells(109, X).Resize(, 3).Value Y = Y + 1 Next X End If .Activate End With Application.ScreenUpdating = True End Sub تم إضافة هذا الكود أرجو أن يكون المطلوب Ehsaa.rar

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

أخي الغالي بن علية أعتذر عن عدم رؤيتي لمشاركتك لم يحدد الأخ السائل ..لذا استخدمت الدالة Floor وحضرتك استخدمت الدالة Ceiling تقبل تحياتي

في الخلية K7 جرب المعادلة بهذا الشكل =IF(H7>0,FLOOR(التشريح!Z7,0.25)," ")

الملف محمي والحمد لله أنا ممكن أكسره بس مش هاعطي نفسي الفرصة إني أعمل كدا ..أنا مؤدب ومش بحب أكسر أعمال الغير ههههه (صقر المنتدى هيعلق أكيد)

السلام عليكم أخي الفاضل تركي طالما تركي ايه اللي جابك في الوطن العربي ..عموما نورت يا كبير وبين إخوانك بردو إليك الملف التالي عله يكون المطلوب Sub YasserKhalil() Dim WS As Worksheet, SH As Worksheet Dim LR As Long, rCell As Range Dim I As Long Dim X As Long, Y As Long Set WS = Sheets("السرب"): Set SH = Sheets("التمام") LR = WS.Cells(Rows.Count, "J").End(3).Row Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False SH.Range("B26:V1000").ClearContents With WS .AutoFilterMode = False .Range("A1:J1").AutoFilter End With For I = 3 To 21 Step 2 With WS .Range("A1:J1").AutoFilter Field:=10, Criteria1:=SH.Cells(24, I).Value .Range("E1").Offset(1, 0).Resize(LR, 2).SpecialCells(xlCellTypeVisible).Copy SH.Cells(26, I).PasteSpecial xlPasteValues End With Next I WS.Cells.AutoFilter Application.CutCopyMode = False Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub تقبل تحياتي AutoFilter Multi Criteria YasserKhalil.rar

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

أخي الحبيب سعيد بيرم صحيح أنا مش فاهم الدنيا ماشية إزاي بس جرب المعادلة التالية في الخلية H13 =IF(B13="H",MOD(100*ROUNDDOWN(SUM(G13,F13/100)*3.25%,1),100),MOD(IF(B13="H",ROUNDDOWN(E13*3.25%,1),IF(C13<=266.5,"",ROUNDDOWN(IF(C13>266.5,(C13-266.5)*13.2%*D13*2.75%),1))),1)*100) ثم قم بسحبها

أخي الفاضل بكري ممكن ترفق الملف الأصلي للعمل عليه مرة واحدة حتى يكون العمل مكتمل لدي بعض الأفكار ولكنها لم تكتمل بعد .. فالرجاء إرفاق الملف الأصلي للعمل عليه سؤال : الجداول الموجودة في ملف الورد غير ضرورية أليس كذلك ..؟؟ المطلوب فقط في الأسطر التي فوق الجداول.. أمر آخر لاحظت في الورقة الأولى أن الأرقام غير منضبطة إلى حدٍ ما . هل هذا الأمر في صفحات كثيرة؟ الرقم السري لاحظت أيضاً أحيانا بيكون فيه عدد 2 س ومرات مفيش .. هل هذا منطقي؟ عموما هي مجرد محاولات للوصول لحل سريع أو على الأقل نصف حل

أخي الكريم عبد العزيز .. إليك الملف التالي عله يفي بالغرض File Zizo.rar

الأخ الفاضل حليم ناصر إليك الفيديو التالي