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

أعتذر عن عدم التوضيح للطريقة قم بالذهاب إلى التبويب Formulas ثم انقر Name Manager ثم انقر الأمر New .. لعمل نطاق باسم Test وضع المعادلة التالية في الحقل Refers to = EVALUATE($A2) بكدا يكون عندك نطاق مسمى باسم Test ضع المعادلة التالية في الخلية A2 ليتم المطلوب =Test

إذا كان هناك أكثر من لون أي أنه توجد شروط عديدة يمكن استخدام دالة الجمع بشروط متعددة SUMIFS بدلاً من SUMIF

أخي الكريم أبو عبد الملك جرب الكود التالي بعد التعديل Sub FollowAll() Dim I As Long, lRow As Long Dim rngFound As Range Dim wsRecord As Worksheet, wsMonthly As Worksheet, SH As Worksheet Set wsRecord = Sheets("معلومات التسجيل"): Set wsMonthly = Sheets("مجمع النتائج الشهرية"): Set SH = Sheets("كشف متابعة") With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With With wsRecord For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row If Not IsEmpty(.Cells(I, "N")) Then If MsgBox("الطالب " & .Cells(I, "C") & " منقطع هل تود أن تطبع له كشف?", vbYesNo + vbMsgBoxRtlReading) = vbYes Then GoTo Continue Else: End If Else Continue: SH.Range("C1") = .Cells(I, "C") SH.Range("C4") = .Cells(I, "B") SH.Range("C5") = .Cells(I, "A") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(I, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious) If Not rngFound Is Nothing Then lRow = rngFound.Row If wsMonthly.Cells(lRow, "R") >= 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O") ElseIf wsMonthly.Cells(lRow, "R") < 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M") Else MsgBox "لا يوجد درجة للطالب " & .Cells(I, "C"), vbCritical End If End If SH.Range("C2").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))" SH.Range("C3").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$D$2:$D$6))" SH.Range("C2:C3").Value = SH.Range("C2:C3").Value Call CalculateLinesOfRevision SH.PrintPreview End If Next I End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub Private Sub CalculateLinesOfRevision() Dim SH As Worksheet, wsMnhg As Worksheet Dim LRCur As Long, I As Long, II As Long, N As Long, Counter As Long, P As Long Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range Dim X, Y, Z Set SH = Sheets("كشف متابعة"): Set wsMnhg = Sheets("المنهج") With wsMnhg LRCur = .Cells(Rows.Count, 1).End(xlUp).Row Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur) Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur) SH.Range("Q11:Q34").ClearContents X = ValueLookUp(rngB, SH.Cells(4, "R").Value, rngC, rngD, SH.Cells(4, "S").Value, rngA) If X <= 24 Then For I = 2 To X + 1 SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I, "B") & " " & .Cells(I, "D") N = N + 1 Next I Else Y = Application.WorksheetFunction.Ceiling(X / 24, 1) For I = 2 To X + 1 Step Y SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I + Y - 1, "B") & " " & .Cells(I + Y - 1, "D") N = N + 1 Counter = Counter + Y If Y >= X - I Then Exit For Next I If X - Counter > 0 Then SH.Cells(N + 11, "Q") = .Cells(I + Y, "B") & " " & .Cells(I + Y, "C") & " - " & .Cells(X + 1, "B") & " " & .Cells(X + 1, "D") End If SH.Range("O11:O34").ClearContents Z = X - 24 If Z > 0 Then SH.Range("O11:O34") = .Cells(Z, "B") & " " & .Cells(Z, "D") & " - " & SH.Range("R4") & " " & SH.Range("S4") SH.Range("M11:M34,I11:I34,G11:G34").ClearContents P = 1 For II = 11 To 34 SH.Range("M" & II) = .Cells(X + P, "B") & " " & .Cells(X + P, "C") & " - " & .Cells(X + P, "D") SH.Range("I" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 1, "D") SH.Range("G" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 6, "B") & .Cells(X + P + 6, "D") P = P + 1 Next II SH.Range("M11:M34").Copy SH.Range("K11") End With End Sub

أخي الكريم توكل الموضوع في هذه الحالة ليس بحاجة إلى أكواد أو دوال معرفة فقط قم بوضع المعادلة بهذا الشكل في الخلية C11 =SUMIF(A1:A11,"<=" &10) أي الجمع بشرط يفي بالغرض

أخي الكريم سليم 'أو يمكن استخدام المعادلة التالية لتؤدي نفس الغرض =LEFT(A2,FIND("*",A2)-1)*RIGHT(A2,FIND("*",A2)-1) 'وضع المعادلة التالية [Test] أو يمكن تسمية نطاق باسم معين وليكن = EVALUATE($A2) 'ضع المعادلة التالية [B2] في الخلية =Test Evaluate.rar

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

أخي الغالي جعفر صراحةً لم أفهم الفكرة .. هل من الممكن إلقاء مزيد من الضوء عىلى فكرة الموضوع؟

أخي الحبيب جعفر قمت بتجربة الكود ووضعته في حدث المصنف كما وضحت وحفظت الملف ثم أغلقته .. قمت بعمل نسخ ولصق مرة ، ثم قمت بعمل قص ولصق مرة .. ولم يحدث أي شيء !! من المفترض أن أحصل على رسالة تفيد أنني على وشك القيام بنسخ أو لصق ..أليس كذلك؟ النسخة لدي أوفيس 2007 32 بت تقبل تحياتي

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

أخي الكريم توكل يمكنك طرح موضوع مستقل بطلبك مع إرفاق ملف للتوضيح

أخي الكريم قم بضغط ملفك ثم ارفعه على المنتدى بدلاً من الروابط الخارجية

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

أخي الحبيب مختار أخي الحبيب جعفر بارك الله فيكما وجزاكما الله خير الجزاء في الدنيا والآخرة

أخي الحبيب حسام بارك الله فيك وجزاك الله كل خير إيماناً منا بروح الفريق واللعبة الحلوة أحب أثري الموضوع بدالة تقوم بالمهمة Function SumByColor(CellColor As Range, rRange As Range) Dim cSum As Double, CL As Range Dim ColIndex As Integer ColIndex = CellColor.Interior.ColorIndex For Each CL In rRange If CL.Interior.ColorIndex = ColIndex Then cSum = WorksheetFunction.Sum(CL, cSum) End If Next CL SumByColor = cSum End Function تقبلوا تحياتي Sum Colors Using UDF Function.rar

أخي الكريم أحمد الطحان يرجى تغيير اسم الظهور للغة العربية جرب المعادلة التالية في الخلية E27 =MOD(SUM(E15:E26),24) والمعادلة التالية في الخلية F27 =SUM(F15:F26,INT(MOD(SUM(E15:E26)/24,24))) تقبل تحياتي

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

مش هطول في الكلام أخي الغالي مختار هما كلمتين وبس :: ما أروعك!

أخي الكريم قنديل الصياد بارك الله فيك كنت قد جهزت الملف بالأمس ولكن انقطعت الكهرباء فجأة إليكم الملف التالي Sort Data.rar

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

أخي الحبيب جعفر جربت دالتك وأعطت نتائج بالسالب وغير صحيحة .. نرجو التصحيح للاستفادة منها إن شاء الله Function AlphaSum(ByVal Word As String) As Long Dim i As Long Word = Replace(Word, " ", "") For i = 1 To Len(Word) AlphaSum = AlphaSum + Asc(Mid(Word, i, 1)) - IIf(Asc(Mid(Word, i, 1)) > &H63A, &H626, &H620) Next End Function

أخي الحبيب جعفر أتعبتك معي .. لا عليك الكود لم يعمل أيضاً .. لا أدري أين الخلل ؟؟؟ عموماً دعك من الأمر الآن ..يمكنني الانتظار حتى تقوم بتحديث نظام الويندوز لديك تقبل وافر تقديري واحترامي

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

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

بارك الله فيك أخي الحبيب بكار على الموضوع الرائع تقبل وافر تقديري واحترامي

=ramhan(d2)