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

إليك رابط القناة حاول تتابعها وتستفيد منها بأكبر قدر وإن شاء الله مع الوقت تقدر تكتب أكواد بنفسك .. الموضوع ما هو إلا ممارسة وتدريب وتطبيق (ما ولدنا من بطون أمهاتنا وكنا نعرف كتابة الأكواد بل تعلمناها بمرور الوقت مع التدريب والممارسة) YasserKhalil ExcelLover

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

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

وجزيت خيراً أخي الكريم ناصر اطلعت على الملف ووجدت عدد كيبر من الموديولات .. أي موديول أو كود تريد تعديله .. وهذه الميزة يمكن إضافتها باستبدال الجزء المتغير بجزء ثابت يتم استخدامه بشكل دائم مثال: لو أن لديك النطاق A1:B6 ومستخدم في الكود أكثر من مرة فيمكن ببساطة وضع سطر بهذا الشكل في بداية الكود Const strRange As String="A1:B6" ثم استخدم المتغير المسمى strRange (يمكن تسميته بما شئت ..) يمكن استخدامه في أي سطر موجود فيه النطاق على سبيل المثال : Sheets("Sheet1").Range("A1:B6").ClearContents سيكون بهذا الشكل بعد إضافة السطر الأول Sheets("Sheet1").Range(strRange).ClearContents لاحظ أنه تم استبدال النطاق A1:B6 بالمتغير الثابت وهكذا لأي متغير لديك ...

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

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

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

وعليكم السلام أخي الكريم حسين بارك الله فيك ومشكور على كلماتك الطيبة الكود بسيط جداً وليس معقد كما تعتقد .. فكرة الكود عمل حلقة تكرارية لأوراق العمل داخل المصنف (وقد قدمت فيديو لذلك) ، مع استثناء أوراق عمل معينة وقد أشرت إلى تلك النقطة في مشاركة سابقة حيث يوضع الشرط بعد بداية الحلقة وقبل نهاية الحلقة .. وما بين أسطر الحلقات يتم نسخ البيانات في أعمدة مساعدة تحددها بنفسك ففي المثال الأصلى استخدمت العمود I إلى M يمكن استخدام أي أعمدة بعيدة عن البيانات ... حدد السطر التالي Application.CutCopyMode = False ثم اضغط F9 من لوحة المفاتيح ونفذ الكود لهذا السطر فقط .. ستجد أن البيانات تم نسخها من أوراق العمل المختلفة إلى العمود رقم 9 .. قم بتغيير الرقم 9 إلى أي رقم عمود آخر Feuil1.Cells(Rows.Count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues هذا فقط للتوضيح وسيلزم تغييرات أخرى في الأسطر اللاحقة من الكود ولكن أحببت أن أوضح لك البداية لكي تفهم ما يجري بعد ذلك تم الاعتماد على الأعمدة المساعدة في تحقيق المطلوب من خلال معادلات Sumproduct أرجو ان يفي الشرح بالغرض إن شاء الله

السلام عليكم أخي الكريم ناصر ابحث عن الإجراء الفرعي المسمى Sub Kh_JJJ(Nd As String) وعدل السطر التالي If .Cells(R, 1) = Nd Then ليكون بالشكل التالي If .Cells(R, 1) Like "*" & Nd & "*" Then

جرب الكود بالشكل التالي Option Explicit Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim rngDates As Range Dim rngTotal As Range Dim rngFine As Range Application.ScreenUpdating = False Set sh = Feuil1 For Each ws In ThisWorkbook.Worksheets If ws.Name <> "الرئيسية" And ws.Name <> "namodaj" And ws.Name <> "طباعة" Then If ws.Name <> sh.Name Then If ws.Range("B9").Value <> "" Then ws.Range("B9:F" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Copy Feuil1.Cells(Rows.Count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues End If End If End If Next ws Application.CutCopyMode = False If sh.Range("I2").Value = "" Then Exit Sub Set rngDates = sh.Range("I2:I" & sh.Range("I2").CurrentRegion.Rows.Count + 1) Set rngTotal = sh.Range("J2:J" & sh.Range("J2").CurrentRegion.Rows.Count + 1) Set rngFine = sh.Range("M2:M" & sh.Range("J2").CurrentRegion.Rows.Count + 1) With sh.Range("E4:E" & sh.Cells(Rows.Count, 4).End(xlUp).Row) .Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(D4))*(YEAR(" & rngDates.Address & ")=YEAR(D4)),--(" & rngTotal.Address & "))" .Offset(, 1).Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(D4))*(YEAR(" & rngDates.Address & ")=YEAR(D4)),--(" & rngFine.Address & "))" .Offset(, 2).Formula = "=SUM(E4:F4)" .Resize(, 2).Value = .Resize(, 2).Value End With sh.Columns("I:M").ClearContents Application.Goto sh.Range("A1") Application.ScreenUpdating = True End Sub

وعليكم السلام إذا أردت عمل استثناء لأوراق عمل معينة قم بإضافة سطر بعد سطر الحلقة التكرارية شبيه بما قدمه أخونا زيزو العجوز If sh.Name <> "الرئيسية" And sh.Name <> "namodaj" And sh.Name <> "طباعة" Then ولا تنسى الجملة End IF قبل نهاية الحلقة التكرارية

جرب الكود التالي Sub SortColumnsByColorCount() Dim iCol As Long Dim firstRow As Long Dim lastRow As Long Dim i As Long Dim x As Long Application.ScreenUpdating = False firstRow = 3 lastRow = Range("B" & firstRow).CurrentRegion.Rows.Count + firstRow - 1 For iCol = 2 To 6 Cells(lastRow + 1, iCol).Value = ColorFunction(Range(Cells(3, iCol), Cells(lastRow, iCol))) Next iCol Range("B" & firstRow & ":F" & lastRow + 1).Sort Key1:=Range("B" & lastRow + 1), Header:=xlNo, Orientation:=xlLeftToRight Range("B" & lastRow + 1 & ":F" & lastRow + 1).ClearContents Application.ScreenUpdating = True End Sub Function ColorFunction(rRange As Range) Dim rCell As Range Dim vResult As Long For Each rCell In rRange If rCell.Interior.ColorIndex <> -4142 Then vResult = vResult + 1 End If Next rCell ColorFunction = vResult End Function

وعليكم السلام جرب المعادلة =IF($A2="","",IF(ROUND((SUM($C$1)-(($A2*18.5%)+SUM($B2)*10%)),2)<0,0,ROUND((SUM($C$1)-(($A2*18.5%)+SUM($B2)*10%)),2)))

يمكن نسخ النتائج ووضعها في مكان البيانات الأصلية بسطر آخر يقوم بعملية النسخ ثم حذف الصفوف المساعدة

وعليكم السلام جرب الكود التالي Sub SortColumnsByColorCount() Dim arr() As Variant Dim iCol As Long Dim firstRow As Long Dim lastRow As Long Dim i As Long Dim x As Long Application.ScreenUpdating = False firstRow = 3 lastRow = Range("B" & firstRow).CurrentRegion.Rows.Count + firstRow - 1 For iCol = 2 To 6 ReDim Preserve arr(iCol - 2) arr(UBound(arr)) = Val(ColorFunction(Range(Cells(3, iCol), Cells(lastRow, iCol))) & "." & iCol) Next iCol Call BubbleSort(arr()) For i = LBound(arr) To UBound(arr) x = Val(Split(CStr(arr(i)), ".")(1)) Range(Cells(3, x), Cells(lastRow, x)).Copy Cells(3, iCol + 2) iCol = iCol + 1 Next i Application.ScreenUpdating = True End Sub Function ColorFunction(rRange As Range) Dim rCell As Range Dim vResult As Long For Each rCell In rRange If rCell.Interior.ColorIndex <> -4142 Then vResult = vResult + 1 End If Next rCell ColorFunction = vResult End Function Sub BubbleSort(list()) Dim first As Long Dim last As Long Dim i As Long Dim j As Long Dim temp As Double first = LBound(list) last = UBound(list) For i = first To last - 1 For j = i + 1 To last If list(i) > list(j) Then temp = list(j) list(j) = list(i) list(i) = temp End If Next j Next i End Sub

وعليكم السلام جرب الكود التالي Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim rngDates As Range Dim rngTotal As Range Application.ScreenUpdating = False Set sh = Feuil1 For Each ws In ThisWorkbook.Worksheets If ws.Name <> sh.Name Then If ws.Range("B9").Value <> "" Then ws.Range("B9:E" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Copy Feuil1.Cells(Rows.Count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues End If End If Next ws Application.CutCopyMode = False If sh.Range("I2").Value = "" Then Exit Sub Set rngDates = sh.Range("I2:I" & sh.Range("I2").CurrentRegion.Rows.Count + 1) Set rngTotal = sh.Range("J2:J" & sh.Range("J2").CurrentRegion.Rows.Count + 1) With sh.Range("E4:E" & sh.Cells(Rows.Count, 4).End(xlUp).Row) .Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(D4))*(YEAR(" & rngDates.Address & ")=YEAR(D4)),--(" & rngTotal.Address & "))" .Value = .Value End With sh.Columns("I:J").ClearContents Application.Goto sh.Range("A1") Application.ScreenUpdating = True End Sub

ماذا لو كان طول النص 17 ؟ ماذا لو كان طول النص 18؟ ماذا لو كان طول النص 19؟ ماذا لو كان طول النص 20؟ وسؤال : ما الغرض من تقسيم النص بهذه الطريقة؟ مجرد فضول

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

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

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

ضع ملف مرفق ليساعدك الأخوة بالمنتدى

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

يمكن إضافة هذا السطر في حدث تغير ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) Application.CalculateFull End Sub أو من لوحة المفاتيح Ctrl + Shift + F9

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

السلام عليكم اطلع على الرابط التالي فيه ما تريد إن شاء الله من هنا