Yasser Fathi Albanna

للرفع

أستاذى القدير / ibn_egypt أطمع بشرح كيفية عمل هذا العمل العظيم

السادة الأفاضل لدى ملف يقوم بفلترة المكرر بما أمامه أى المتشابهين أريد تغيير الكود ليقوم بفرز المكرر من الأسماء مع جمع إجمالى المبيعات للإسم بعد فرزة من المكرر والكود هو Sub Duplicata() Set MySheet = Sheets("Filter") With MySheet Last = .Cells(Rows.Count, "D").End(xlUp).Row + 1 .Range("D4:F" & Last).ClearContents x = 4 Application.ScreenUpdating = False Dim i As Integer For i = .Range("B" & Rows.Count).End(xlUp).Row To 4 Step -1 If WorksheetFunction.CountIf(.Range("B4:B" & i), .Range("B" & i).Value) = 1 Then .Range("B" & i).Resize(1, 2).Copy .Range("D" & x).PasteSpecial Paste:=xlPasteValues x = x + 1 End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End With End Sub ولكم خالص الشكر والتقدير مرفق الملف فرز المكرر بإجمالى مبيعاته.rar

عزيزى وأخى الفاضل / محمد الريفى ممكن تطبيق كود برمجى بزر لتنفيذ المطلوب بدلا من المعادلات فى المشاركة رقم 26 للضرورة ولكى خالص شكرى وتقديرى

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

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

للرفع بعد إذن الجميع

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

الرجاء المساعدة للضرورة بعد إذن الجميع

السادة الأفاضل / عمالقة الإكسيل تحية طيبة وبعد الرجاء المساعدة فى التقرير المرفق والمطوب كالتالى الشيت يوجد به عدة مندوبين وكل مندوب مربوط على فرع معين بعملاء معينة ويوجد لكل مندوب مبيعات بالأصناف المربوطة أيضا بشركات معينة المطلوب - فرز كل مندوب بفرعة بمبيعاته فى كل شركة من الشركات بأصناف هذه الشركة بإجمالى قيمة المبيعات و بالعملاء المربوطين عليه أيضا على حدا مع عدم تكرار إسم المندوب أكثرة من مرة أى يكون مرة واحدة وأيضا عدم تكرار فرعة أيضا - أى الإسم فقط وأمامه إسم الفرع التابع له فقط وأمامه إسم الشركة ثم الأصناف المباعة فى هذه الشركة والعملاء المباع لهم هذه الأصناف - تطبيق الفلترة فى شيت 2 بكود برمجى والشكل المطلوب للفلترة موجود بشيت 2 كمثال على مندوب ولسيادتكم خالص الشكر والتقدير مع وافر التحية رابط التحميل نظرا لحجم الملف http://www.gulfup.com/?JzGGQ9

الكود الثالث وهو يقوم بعمل إضافة لصفحة جديدة ( workbook ) كما تشاء من عدد الصفحات Sub Del_Empty_Rows() Dim R As Long Dim rng As Range Application.ScreenUpdating = False If Selection.Rows.Count > 1 Then Set rng = Selection Else Set rng = ActiveSheet.UsedRange.Rows End If For R = rng.Rows.Count To 1 Step -1 If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then rng.Rows(R).EntireRow.Delete End If Next R Application.ScreenUpdating = True End Sub مرفق مثال List workbook defined names.rar

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

الكود الثانى Delete Empty Rows وهو يقوم بحذف الصفوف الفارغة ما بين البيانات المدونة بالشيت مع الحفاظ على الصفوف التى بها بيانات Sub Del_Empty_Rows() Dim R As Long Dim rng As Range Application.ScreenUpdating = False If Selection.Rows.Count > 1 Then Set rng = Selection Else Set rng = ActiveSheet.UsedRange.Rows End If For R = rng.Rows.Count To 1 Step -1 If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then rng.Rows(R).EntireRow.Delete End If Next R Application.ScreenUpdating = True End Sub مرفق مثال للتجربة Delete Empty Rows.rar

من عنيا يا أ / ياسر إنت تأمر سوف أكوم بشرح فائدة كل كود مع إرفاق مثال ولكن مش بنفس الترتيب بالمشاركة الأولى حتى يتم عمل مثال فى البداية كود Rename Worksheet يقوم هذا الكود كما موضح بتسمية شيت 1 بنفس إسم ملف الإكسيل يمكن تغيير الشيت المراد تسميته بنفس إسم ملف الإكسيل كما تريد Sub Rename_Sheet() Dim workbookName As String workbookName = ActiveWorkbook.Name If Len(workbookName) > 26 Then Exit Sub workbookName = Left(workbookName, Len(workbookName) - 4) Sheets(1).Name = workbookName End Sub شاهد المرفق وقم بالتجربة Rename Worksheet.rar

Remove Hyperlinks Sub Remove_Hyperlinks() If TypeName(Selection) <> "Range" Then Exit Sub Application.ScreenUpdating = False Selection.Hyperlinks.Delete Application.ScreenUpdating = True End Sub Delete Empty Rows Sub Del_Empty_Rows() Dim R As Long Dim rng As Range Application.ScreenUpdating = False If Selection.Rows.Count > 1 Then Set rng = Selection Else Set rng = ActiveSheet.UsedRange.Rows End If For R = rng.Rows.count To 1 Step -1 If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then rng.Rows(R).EntireRow.Delete End If Next R Application.ScreenUpdating = True End Sub Paste Values in Selected Cells Sub Paste_Values() Application.ScreenUpdating = False With Selection .Copy .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, _ Transpose:=False End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Convert phone numbers Sub Convert_Phone() Application.ScreenUpdating = False ' ' first highlight the cells you want to scrub ' With Selection.SpecialCells(xlConstants) .Replace what:=Chr(160), Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByColumns, MatchCase:=True .Replace what:=Chr(32), Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByColumns, MatchCase:=True .Replace what:=")", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByColumns, MatchCase:=True .Replace what:="(", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByColumns, MatchCase:=True .Replace what:="-", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByColumns, MatchCase:=True .Replace what:="+", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByColumns, MatchCase:=True End With ' at this point you could do one of two things: ' 1. do a "virtual" format where you just make the cell *appear* to be a ' phone number. ' Selection.NumberFormat = "(###) ###-####" ' 2. We can actually insert the parentheses and dash in the appropriate place. ' ' For each cell in Selection ' cell = "(" & Left(cell, 3) & ") " & Mid(cell, 4, 3) & "-" & Right(cell, 4) ' Next cell ' ' uncomment whichever one you want! ' ' Application.ScreenUpdating = True End Sub Fix Badly Imported Formulas Sub FixFormulas() Dim arrData() As Variant Dim rng As Excel.Range Dim lRows As Long Dim lCols As Long Dim i As Long, j As Long ' let's not accidently use this on a non-Range object If TypeName(Selection) <> "Range" Then Exit Sub lRows = Selection.Rows.Count lCols = Selection.Columns.Count ReDim arrData(1 To lRows, 1 To lCols) Set rng = Selection arrData = rng.Value For j = 1 To lCols For i = 1 To lRows arrData(i,j) = "=" & Right(arrData(i,j), Len(arrData(i,j)) - 1) Next i Next j rng.Value = arrData Set rng = Nothing End Sub Rename Worksheet Sub Rename_Sheet() Dim workbookName As String workbookName = ActiveWorkbook.Name If Len(workbookName) > 26 Then Exit Sub workbookName = Left(workbookName, Len(workbookName) - 4) Sheets(1).Name = workbookName End Sub List workbook defined names Sub ShowNames() ' list workbook names on separate worksheet Dim x As Worksheet Set x = Worksheets.Add Dim nm As Name Dim i As Long i = 1 For Each nm In Names Cells(i, 1) = nm.Name Cells(i, 2) = "'" & nm.RefersTo i = i + 1 Next nm End Sub

حبيبى وأستاذى الغالى / ياسر بالفعل أنت من المبدعين والبادئين بكل ما هو جديد جزيت خيرا يا أخى الكريم وأدام الله عمرك وجعلت زخرا لهذا المنتدى العظيم

أ/ جمال صدق من سماك ملك المعادلات فانت فعلا ملك المعادلات الجميلة أطال الله عمرك وجعله الله فى ميزان حسناتك

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

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

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

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

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

سلمت يداك أستاذى الفاضل / أ / محمد صالح وزادك الله من العلم الكثير والكثير

ا / جمال المشاركة تعطى لا تملك الصلاحية للتحميل إيه السبب

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