ارجو المساعدة بكود وبمعادلة لاستخراج اقسام المدرسة وارقام الجلوس

[فضل حسين]

الى خبراء واعضاء منتداى العزيز والعظيم

كل عام وانتم بخير

مرفق ملف موضح به المطلوب

وجزاكم الله كل خير ........... وشكرا

استخراج اقسام المدرسة وارقام الجلوس لكل قسم .rar

[رجب جاويش]

أخى فضل

السلام عليكم ورحمة الله وبركاته

كل عام وأنتم بحير

تفضل أخى ما تريد

Sub ragab()

Application.ScreenUpdating = False

[H3:K100].ClearContents

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row

cl = Trim(Cells(i, 1))

If cl = [H2] Then

cll = Trim(Cells(i, 2))

x = UBound(Filter(Split(MyArr, ","), cll)) + 1

If x = 0 Then MyArr = MyArr & Trim(cll) & ","

End If

Next

MyArr = Left(MyArr, Len(MyArr) - 1)

ii = 3

For Each c In Split(MyArr, ",")

Cells(ii, 8) = c

ii = ii + 1

Next

For y = 3 To 15

For t = 2 To 37

	 If Cells(t, 1) = [H2] And Cells(t, 2) = Cells(y, "H") Then

	 Cells(y, "H").Offset(0, 1) = Cells(t, 3): Exit For

	 End If

Next

Next

For y = 3 To 15

For t = 2 To 37

	 If Cells(t, 1) = [H2] And Cells(t, 2) = Cells(y, "H") Then

	 Cells(y, "H").Offset(0, 2) = Cells(t, 3)

	 Cells(y, "H").Offset(0, 3) = (Cells(y, "H").Offset(0, 2).Value - Cells(y, "H").Offset(0, 1).Value) + 1

	 End If

Next

Next

Application.ScreenUpdating = True

End Sub

استخراج اقسام المدرسة وارقام الجلوس لكل قسم .rar

[فضل حسين]

استاذى الفاضل / نجم الاكسل

رجب جاويش

صاحب العلم الكبير والخلق الرفيع

سلام الله عليكم ورحمته وبركاته ..... وكل عام وانتم بخير

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

فكل الاحترام والتقدير والشكر لشخصكم الجليل على هذا العمل الرائع مثلكم وهو المطلوب بالفعل وجزاكم الله كل خير .

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

وشكرا

اخوك فضل

تم تعديل يوليو 17, 2012 بواسطه فضل 1

[رجب جاويش]

شكرا جزيلا أخى فضل

وجزاك الله كل خير

[عبدالله باقشير]

السلام عليكم

بارك الله فيك اخي الحبيب رجب

ولاثراء الموضوع

Sub kh_Start()

Dim Ar

Dim r As Integer, c As Integer, i As Integer

Dim st As String

[H3:K100].ClearContents

For r = 2 To Range("A" & Rows.Count).End(xlUp).Row

    If CStr(Cells(r, 1)) = CStr([H2]) Then

        st = CStr(Cells(r, 2))

        If WorksheetFunction.CountIf(Range("H3").Resize(i + 1), st) = 0 Then

            i = i + 1

            Ar = mTest(CStr([H2]), st)

            For c = 1 To 4

                Range("H3").Cells(i, c).Value = Ar(c - 1)

            Next

        End If

    End If

Next

End Sub

Function mTest(nT As String, nS As String) As Variant

Dim x As Integer, xx As Integer

Dim iMX As Long, iMN As Long

For x = 2 To Range("A" & Rows.Count).End(xlUp).Row

    If CStr(Cells(x, 1)) = nT Then

        If CStr(Cells(x, 2)) = nS Then

            xx = xx + 1

            If xx = 1 Then iMN = Val(Cells(x, 3))

            If Val(Cells(x, 3)) < iMN Then iMN = Val(Cells(x, 3))

            If Val(Cells(x, 3)) > iMX Then iMX = Val(Cells(x, 3))

        End If

    End If

Next

mTest = Array(nS, iMN, iMX, xx)

End Function

يعمل الكود تلقائيا عند التغيير في الخلية H2

المرفق 2003

استخراج اقسام المدرسة وارقام الجلوس لكل قسم .rar

[رجب جاويش]

الله الله الله

للإبداع فى هذا المنتدى عنوان واضح واسم محدد

وهو الأستاذ / عبد الله باقشير

حفظك الله وبارك فيك

[عبدالله باقشير]

الله الله الله

للإبداع فى هذا المنتدى عنوان واضح واسم محدد

وهو الأستاذ / عبد الله باقشير

حفظك الله وبارك فيك

اكرمك الله في الدارين

وشهركم مبارك

تقبل تحياتي وشكري

[محمدي عبد السميع]

حفظك ربنا ورعاك ايها العالم العلامة

والبحر الفهامه عبد الله باقشير

[فضل حسين]

العلامة الكبير الاستاذ الكبير

عبدالله باقشير

كل سنة وسيادتكم بخير بمناسبة شهر رمضان المبارك اعاده الله عليك وعلى الاسرة وعلى الامة الاسلامية بالخير واليمن والبركات

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

وانا سعيد جدا بهذه المشاركة . جزاك الله كل خير يااستاذنا الكبير على هذا الكود الرائع وعلى هذا العلم والابداع فى الاداء .

ولكن لى ملحوظة بسيطة اسمح لى يااستاذنا الكبير ان اوضحه لسيادتكم

وهى عندما اقوم بزيادة البيانات الى مثلا 60000 سطر الكود لايعمل ويظهر خطأ ولااعرف ماهو السبب .

بالطبع اكرر شكرى وامتنانى وحبى للعلامة الكبير على هذا العمل الرائع واستئذنه فى الرد على ملحوظتى البسيطة

بارك الله فيك ياعلامة وربنا يخليك لنا معلما واستاذا واخا فاضلا

جزاك الله كل خير

[عبدالله المجرب]

الاستاذ عبدالله باقشير

ابداع ما بعده اباع

<<<<<<<<<<

الاستاذ رجب

عمل مميز ونشاط واضح

كل سنة وانتم بخير

[رجب جاويش]

الأستاذ الفاضل / عبد الله المجرب

جزاك الله كل خير على هذا التشجيع

وكل عام وأنتم بخير

وفقكم الله لما يحب ويرضى

أخوك / رجب جاويش

[جمال عبد السميع]

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

[رجب جاويش]

أخى الحبيب / محمود

جزاك الله كل خير على هذه الروح الطيبة

وكل عام وأنتم بخير

تقبل الله منا ومنكم صالح الأعمال

[عبدالله المجرب]

أخى الحبيب / محمود

جزاك الله كل خير على هذه الروح الطيبة

وكل عام وأنتم بخير

تقبل الله منا ومنكم صالح الأعمال