سليم حاصبيا

تم تحسين الكود قليلاً لتكون النتيجة اكثر فائدة Option Explicit Sub Trasfer_data_Special() Dim R As Worksheet, Act_sh As Worksheet Dim k%, col%, Ro% Dim Max_ro%, x%, y% Dim Bol As Boolean Dim ST_Dat As Date Dim End_Dat As Date Dim My_sum# Dim Mot$ Mot = "الاجمالى" Set R = Sheets("Report_Youmi") Ro = R.Cells(Rows.Count, 1).End(3).Row R.Range("C3").CurrentRegion.Resize(Ro - 1).ClearContents R.Cells(3, 9).Resize(Ro + 1).ClearContents R.Cells(Ro + 1, 9).Resize(2).ClearContents ST_Dat = Application.Min(R.Range("I2:J2")) End_Dat = Application.Max(R.Range("I2:J2")) For k = 3 To Ro Bol = Application.Evaluate _ ("ISREF('" & R.Range("A" & k) & "'!A1)") If Bol Then Set Act_sh = Sheets(R.Range("A" & k) & "") Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row For y = 3 To 7 For x = 5 To Max_ro If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _ CDate(Act_sh.Cells(x, 1)) <= End_Dat And _ Act_sh.Cells(x, 2) <> Mot Then My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _ Act_sh.Cells(x, y + 2), 0) End If Next x R.Cells(k, y).Value = My_sum: My_sum = 0 Next y End If Next k R.Cells(Ro + 1, 3).Resize(, 5).Formula = _ "=Sum(C$3:C$" & Ro - 2 & ")" R.Cells(3, 9).Resize(Ro - 1).Formula = _ "=IF(COUNTA($C3:$G3)>0,SUM($C3:$G3),"""")" R.Cells(Ro + 2, 9) = "Sum Of All" R.Range("A3:I" & Ro + 2).Value = _ R.Range("A3:I" & Ro + 2).Value End Sub الملف مرفق My_Repport_Final_1.xlsm

تم ادراج ماكرو جديد يقوم بما تريد Option Explicit Sub Trasfer_data_Special() Dim R As Worksheet, Act_sh As Worksheet Dim k%, col%, Ro%, Max_ro%, x%, y% Dim Bol As Boolean Dim ST_Dat As Date Dim End_Dat As Date Dim My_sum# Dim Mot$ Mot = "الاجمالى" Set R = Sheets("Report_Youmi") Ro = R.Cells(Rows.Count, 1).End(3).Row R.Range("C3").CurrentRegion.ClearContents ST_Dat = Application.Min(R.Range("I2:J2")) End_Dat = Application.Max(R.Range("I2:J2")) For k = 3 To Ro Bol = Application.Evaluate _ ("ISREF('" & R.Range("A" & k) & "'!A1)") If Bol Then Set Act_sh = Sheets(R.Range("A" & k) & "") Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row For y = 3 To 7 For x = 5 To Max_ro If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _ CDate(Act_sh.Cells(x, 1)) <= End_Dat And _ Act_sh.Cells(x, 2) <> Mot Then My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _ Act_sh.Cells(x, y + 2), 0) End If Next x R.Cells(k, y).Value = My_sum: My_sum = 0 Next y End If Next k End Sub الملف مرفق My_Repport_Final.xlsm

هذا يتعلق بمكان وجود كلمة اجمالي (اقصد في اى عامود) ارفع نموذج بسيط عما تريد (صفحتين لا أكثر لمعرفة سير الكود) تحتوي على بيانات و بدون زركشة ألوان

اذا كان الاجمالي موجود For x = 2 To Max_ro - 1 و (في حال عدم وجود الاجمالي) For x = 2 To Max_ro بالنسبة للخطأ جرب استبدال هذا السطر ("ISREF('" & R.Range("A" & k) & "'!A1)") بهذا ("ISREF('" & R.Range("A" & k )&"" & "'!A1)") ملاحظة اخرى انت تدرج ارقاماً لاسماء الصفحات جرب ان تدرج نصوصاً مثل Amin ,Kamel ,Mouhammed الخ....

اجذف الناقص 1 من هنا (يمكن الاحتفاظ بها في حال وجود الاجمالي في كل صفحة)

تم معالجة الأمر My_Repport.xlsm

ارفع الملف للمعاينة

تأكد ان الخلايا I2 & J2 والغامود الأول في كل صفحة بتنسيق Date

1- تم تغيير اسماء الصفحات اى اللغة الأجنبية لسهولة نسخ الكود ولصقه 2-تم التعديل على الجدول في صفحة ("Report_Youmi") بحيث يكون مستقلاً عن باقي الخلايا (ادراج عامودين فارغين H و B و صف فارغ رفم 2) 3- عملية الجمع تتم حسب التاريخ وليس حسب كلمة اجمالي ( فاذا كان التاريخ في العمود الأول من اي صفحة لا يستوفي شروط بين التاريخين في صفحة Report_Youmi لا يحتسب 4-كل ما عليك فعله هو وضع الأسماء الخقيقية في الجدول (صفحة "Report_Youmi") و تغيير اسماء الصفحات بالأسماء الخقيقية(بالضبط دون مسافات زائدة أو ناقصة ) الأفضل استعمال (Copy Paste) 5- اذا كان اي اسم ليس له صفحة انسخ اي صفخة تريد وضع اسمها حسب الاسم في الجدول 6- The code Option Explicit Sub Trasfer_data() Dim R As Worksheet, Act_sh As Worksheet Dim k%, col%, Ro%, Max_ro%, x%, y% Dim Bol As Boolean Dim ST_Dat As Date Dim End_Dat As Date Dim My_sum# Set R = Sheets("Report_Youmi") Ro = R.Cells(Rows.Count, 1).End(3).Row R.Range("C3").CurrentRegion.ClearContents ST_Dat = Application.Min(R.Range("I2:J2")) End_Dat = Application.Max(R.Range("I2:J2")) For k = 3 To Ro Bol = Application.Evaluate _ ("ISREF('" & R.Range("A" & k) & "'!A1)") If Bol Then Set Act_sh = Sheets(R.Range("A" & k) & "") Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row For y = 3 To 7 For x = 2 To Max_ro - 1 If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _ CDate(Act_sh.Cells(x, 1)) <= End_Dat Then My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _ Act_sh.Cells(x, y + 2), 0) End If Next x R.Cells(k, y).Value = My_sum: My_sum = 0 Next y End If Next k End Sub الملف مرفق TakRir_Yuomi.xlsm

ربما هذا الماكرو يفي بالغرض Option Explicit Sub Crezy_filter() Dim Sh As Worksheet Dim i%, m%, Lr% Dim Obj As Object Dim My_match Set Sh = Sheets("Sheet1") Set Obj = CreateObject("Vbscript.Regexp") Lr = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Range("C4").CurrentRegion.ClearContents m = 4 With Obj .Pattern = "^([A-Z][a-z]\d+)" .Global = True .ignorecase = False End With For i = 4 To Lr If Obj.test(Sh.Cells(i, 1)) Then Set My_match = Obj.Execute(Sh.Cells(i, 1)) Sh.Cells(m, 3) = Sh.Cells(i, 1) m = m + 1 End If Next Set Obj = Nothing End Sub الملف مرفق EE22.xlsm

لأن الشرطة "_" لا يفهما البرنامج على انها مجرد شرطة لذلك اذا اردت ان تدرجها في نص يجب وضعها بين قوسين مثلاً Cells(5,11).value=cells(3,10).value &"_"& cells(5,9).value

اختر واحدة من الخليتين و احذف الثانية مثلاً Cells(5,11).value=cells(3,10).value أو Cells(5,11).value=cells(5,9).value

يمكنك اختيار اي شيء من الخلية B2

لقد فهمت عليك ماذا تريد انظر الى هذا الملف (الصفحة Target_Sh) Indx_match_Code.xlsm

لا حاجة لاضافة مزيد من الازرار او اضافة ماكرو لتحديد المزيد من الخيارات ولا حاجة ايضاً بأن تكون الكلمة المطلوبة في TextBox1 عند تنشيط اليوزر هي "In" عناوين الــ Labels تتغير حسب الـ CheckBox المختار Extra_Search.xlsm

صديقي لست بحاجة الى ادراج ماكرو آخر لهذا الغرض يكفي 2 تشيك بوكس واحد (لجميع الكلمات او أول كلمة ) والثاني (Bold Or Not) انظر الى هذا الملف All_Saerch_In With_User_Option.xlsm

هذا الكود Dim iStart As Integer, iEnd As Integer, I As Integer iStart = Sheet1.Range("B1").Value iEnd = Sheet1.Range("C1").Value For I = iStart To iEnd step 2 Sheet1.Range("D12").Value = I Sheets(1).PrintPreview Next I

جرب هذا الملف Joulous.xlsm

بعد اذن الاخ علي هذا الملف Indx_match.xlsx

كان الحجم 994 واصبح 947 كيف قمت بتصغيره

السلام عليم 1-الملف كبير جداً (حوالي 1 ميغا) 2-لم تذكر اين هي صفحة المصدر واين الصفحة الهدف (فقط رقم الصفحة لا يفيد ما ادراني اي صفحة هي شيت1) 3- لا ضرورة لادراج اكثر من 700 صف من البيانات 4- لا ضرورة للألوان الفاقعة التي تزيد من حجم الملف دون اي منفعة 5- ارفع نموذج بسيط (10 صفوف على الأكثر) / لمتابعة عمل المعادلات بشكل سهل و بسيط / لأن المعادلة التي تعمل على صف واحد يمكنها العمل على ألوف الصفوف 6- بعد وضع المعادلات المطلوبة تنسخها الى الملف الأصلي

ممتاز اخي الرائد حتى ولو كان عندي ملاحظة بسيطة من شأنها التسريع (للبيانات الكثيرة) 1 - الدالّة IFERROR في المعادلات الأفضل عدم استعمالها الا للضروروة لأنها تلزم الاكسل على حساب المعادلة واذا وجد خطأ يدرج فراغاً (مما يضيع الوقت سدى / جزء من الف من الثانية بالنسبة للحاسوب شيء كبير جداً / ) هذا بالإضافة الى ارهاق البرنامج بأشياء لا لزوم لها 2- الأفضل استعمال CountA لانه عندما رقم الصف يتجاوز الرقم المطلوب من خلال CountA يقوم اكسل بإدراج الفراغ ولا يفكر حتى بحساب نتيجة المعادلة 3- المعادلة المفترحة من عندي =IF(ROWS(B$4:B4)>COUNTA(A$4:A$1000),"",INDEX(A$4:A$1000,SMALL(IF(A$4:A$1000<>"",ROW(A$4:A$1000)-ROW(A$4)+1),ROWS(B$4:B4))))

التعديل رائع على الكود لكن عندي ملاحظة بالنسبة لهذا الجزء منه (5 سطور) If Me.CheckBox1.Value = True Then .Bold = True Else .Bold = False End If حيث يمكن استبداله بسطر واحد .Bold = Me.CheckBox1.Value

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

تم عمل المطلوب يبدو ان الأمر كان سهلاً (الكومبو بوكس لا يستقبل الكتابة بواسطة الكيبورد تفادياً للخطأ) يمكن ادراج القيم فقط من حلال قائمته المنسدلة كذلك يمكنك التنقل داخل الشيت حتى ولو كان اليوزرفورم ظاهراً All_Saerch_In With_User.xlsm