شرح اعداد كشوفات مدرسية باختيار روؤس الاعمدة عن طريق فورم

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

Dim MyData As Range

Dim mysheetsN As String

Dim mycol As Integer

Private Sub CommandButton1_Click()

Dim sss As String

Dim dd As Integer

sss = sheetsNames.Value

Dim gh As Integer

gh = sheetsNames.ListIndex

Select Case gh


    Case 0

        dd = 21

    Case 1

        dd = 22

    Case 2

        dd = 8

    Case 3

        dd = 25

    Case 4

        dd = 23

    Case 5

        dd = 26

    Case 6

        dd = 24

    End Select

 taqreer dd, sss

End Sub

Private Sub CommandButton2_Click()

Unload Me

End Sub

Private Sub UserForm_Initialize()

With sheetsNames

    .AddItem "ÇáãÍæáæä ááãÏÑÓÉ"

    .AddItem "ÇáãÍæáæä ãä ÇáãÏÑÓÉ"

    .AddItem "ãÚíÏæä"

    .AddItem "ãÑÖì"

    .AddItem "ÇáÃíÊÇã"

    .AddItem "ÇáÅäÐÇÑÇÊ"

    .AddItem "ÇáãÕÑæÝÇÊ"

    .ListIndex = 0

End With

End Sub

Public Function taqreer(mycol As Integer, mysheetName As String)

Dim LDataRow As Long

Sheets("All").Select

LDataRow = Cells(Rows.Count, 2).End(xlUp).Row

Dim myrow As Long

myrow = 1

Set MyData = Range(Cells(myrow, 2), Cells(LDataRow, 50))

  i = 6

Sheets(mysheetName).Select

Range("b6:c1000").ClearContents

 For myrow = 5 To LDataRow

 With MyData

      If Not IsEmpty(.Cells(myrow, mycol).Value) Then

          Cells(i, 2) = .Cells(myrow, 1)

       Cells(i, 3) = .Cells(myrow, mycol)

       i = i + 1

        End If

  End With

        Next myrow

End Function

=============================

ملحوظة :

=============================

عندما تقوم بنسخ كود فيه كلمات باللغة العربية

حول اللغة الى العربي في الاكسل قبل النسخ

ثم قم بنسخها ولصفها هنا

ستظهر حبنها باللغة العربية

وليست طلاسم مثل كودك اعلاه

=============================

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

شوف الفرق بين حلول الأساتذة و حلول التلامذة

حلول الأساتذة لمنع مسح المعادلات :

If Worksheets(Sh_MyDate).Cells(4, i).HasFormula Then

            .BackColor = &HFFC0C0

            .Locked = True

        End If

هذا الجزئية ليس لها علاقة بالخلايا في الشيت من مسح اوغيره وهي تخص التاكست بوكس لتجعله للمعاينة فقط ( لايمكن التعديل فيه) وتاخذ شرط انها للمعاينة من الخلايا اللي في الصف الرابع (اذا كانت فيها معادلات ) -------------- اما شرط تجاوز التعديل في الخلايا اللي فيها معادلات نحتاجه في زر حفظ التغييرات هنا:

For j = 1 To lcol

    If Me.Controls("Textbox" & j).Locked = False Then

        Worksheets(Sh_MyDate).Cells(k + 3, j) = Me.Controls("Textbox" & j).Value

    End If

Next j

توسعنا في الشرح هنا

لاحتياجنا لمثل هذا في اعمال اخرى

خبور خير

[عبد الفتاح كيرة]

السلام عليكم

عندنا - أقصد كا عندنا مشكلة

وتم حلها بطريقتين

المشكلة

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

إلى خلايا فيها معادلات

فيؤدى ذلك إلى مسح المعادلة فى الشيت

الحل كان بطريقتين

الأولى إعادة لصق المعادلة من الخلية التالية

فهذا علاج للمشكلة بعد وقوعها

وهذا ابتكرته أنا

وبعد ذلك

وجدت طريقتك

وهى تقطع الطريق أصلا على المستخدم للعبث بتيكست تلغى المعادلة فى الشيت

وطبعا الطريقة الثانية أفضل بكثير

ثانيا

هذا هو الكود أعدته باللغة العربية

فقل رأيك فيه

Dim MyData As Range

Dim mysheetsN As String

Dim mycol As Integer

Private Sub CommandButton1_Click()

Dim sss As String

Dim dd As Integer

sss = sheetsNames.Value

Dim gh As Integer

gh = sheetsNames.ListIndex

Select Case gh


    Case 0

        dd = 21

    Case 1

        dd = 22

    Case 2

        dd = 8

    Case 3

        dd = 25

    Case 4

        dd = 23

    Case 5

        dd = 26

    Case 6

        dd = 24

    End Select

 taqreer dd, sss

End Sub

Private Sub CommandButton2_Click()

Unload Me

End Sub

Private Sub UserForm_Initialize()

With sheetsNames

    .AddItem "المحولون للمدرسة"

    .AddItem "المحولون من المدرسة"

    .AddItem "مرضى"

    .AddItem "الأيتام"

    .AddItem "الإنذارات"

    .AddItem "المصروفات"

     .ListIndex = 0

End With

End Sub

Public Function taqreer(mycol As Integer, mysheetName As String)

Dim LDataRow As Long

Sheets("All").Select

LDataRow = Cells(Rows.Count, 2).End(xlUp).Row

Dim myrow As Long

myrow = 1

Set MyData = Range(Cells(myrow, 2), Cells(LDataRow, 50))

  i = 6

Sheets(mysheetName).Select

Range("b6:c1000").ClearContents

 For myrow = 5 To LDataRow

 With MyData

      If Not IsEmpty(.Cells(myrow, mycol).Value) Then

          Cells(i, 2) = .Cells(myrow, 1)

       Cells(i, 3) = .Cells(myrow, mycol)

       i = i + 1

        End If

  End With

        Next myrow

End Function

تم تعديل أغسطس 26, 2010 بواسطه kemas

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

الف الف شكر على كل اعمالك واقوالك

لو حبيت اجعل الصف الثالث الموجود في صفحة ALL

اجعله الصف الخامس فين الجزئيه الخاصة بذلك ؟

كيف اجعل عدد الاعمدة اكثر وتاتي في الفريم

هل ممكن وضع صورة للشخص في الفريم

وتتغير الصوره بتغير الشخص

هنا يتم التغيير

'******************************************************

'  اسم ورقة البيانات

Const Sh_MyDate As String = "all"

'------------------------------------------------------

'  رقم صف رؤوس الاعمدة

Const lrow As Integer = 3

'------------------------------------------------------

'  عدد الاعمدة التي تريدها ابتداءا من العمود الاول

Const lcol As Integer = 60

'******************************************************

اما كود نقل الصور اخذناها

من ملف للاخ الحبيب ابو عبدالله اكسيلجي

و لا اريد اسئلة عن هذا الكود

لاني انا نفسي لا اعرف آلية عمل هذا الكود

شاهدي المرفق

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

المرتبات مع الصور1.rar

[عبد الفتاح كيرة]

تلميح ع الماشى

لعرض النموذج مع إمكانية التعامل مع الشيت

UserForm1.Show vbModeless

يعنى يظهر الفورم

وتتعامل مع الشيت بنفس الوقت و تعدل فيه

[عبد الفتاح كيرة]

الكتابة على سطرين فى المسج بوكس

MsgBox "Hello" & vbCr & Application.UserName

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

السلام عليكم

اخي كيماس كودك ممتاز

ولكن ممكن نعدل فيه بعض الشي

ان اردت ذلك ؟؟

وجمعة مباركة للجميع

ودمتم في حفظ الله

خبور خير

[عبد الفتاح كيرة]

السلام عليكم

لنعد للعمل :

---

عندنا مدى غير متجاور الأعمدة

مثلا

a1:c100

و

f1:h100

و

m1:m100

و

q1:r100

كل هذا مدى واحد

و هو كما ترى متعدد و غير متجاور

لدى سؤالان

الأول : ما أفضل طريقة للإشارة لهذا المدى فى الكود

الثانى : إذا كان مجموع الأعمدة فيه هو 10 متفرقة

كيف نلصقه أو ننقله إلى مدى من 10 أعمدة لكن متصل

يعنى ننسخه إلى a1:a10

قلتم يا أستاذ خبور

أن الخلايا المنسوخة

يجب أن يطابق المدى الذى سننقل إليه

-------

مع الشكر

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

السلام عليكم

قلتم يا أستاذ خبور

أن الخلايا المنسوخة

يجب أن يطابق المدى الذى سننقل إليه

لا تتشابك عليك المعلومات

هذا في حالة ربط القيمة

خلايا معينة=خلايا معينة

اما في حالة النسخ واللصق

نحتاج الى خلية واحدة للصق

Sub kh_tr_1()

    Sheets("KH").Cells.ClearContents

    Range("A1:C100,F1:H100,M1:M100,Q1:R100").Copy

    Sheets("KH").Select

    Range("A1").PasteSpecial xlPasteValues

    Application.CutCopyMode = False

End Sub

[عبد الفتاح كيرة]

طيب زين

اقتربنا

هذا إذا كان المدى صفه محددا

كيف نكتبه إذا كان رقم الصف الثانى الذى هو = 100

عبارة عن متغير

Range("A1:C100,F1:H100,M1:M100,Q1:R100").Copy

تم تعديل أغسطس 27, 2010 بواسطه kemas

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

السلام عليكم

هذا إذا كان المدى صفه محددا

كيف نكتبه إذا كان رقم الصف الثانى الذى هو = 100

عبارة عن متغير

لو ترفق ملف وتشرح لي ماذا تريد بالضبط

بيكون احسن

ولكن جرب هذا الكود

Sub kh_tr_2()

Dim X As Range

Dim C As Byte, CC As Byte

Dim IRow As Integer

IRow = 50

Sheets("KH").Cells.ClearContents

For C = 1 To 9

    CC = Choose(C, 1, 2, 3, 6, 7, 8, 13, 17, 18)

    With Range("A1:X" & IRow)

        If X Is Nothing Then Set X = .Columns(CC) Else _

            Set X = Union(X, .Columns(CC))

    End With

Next

If Not X Is Nothing Then

    X.Copy

    Sheets("KH").Select

    Range("A1").PasteSpecial xlPasteValues

    Application.CutCopyMode = False

    Range("A1").Select

End If

End Sub

[عبد الفتاح كيرة]

أستاذنا الفاضل

هذا هو الكود الذى أعمل عليه

الفكرة بسيطة جدا

نسخ مدى غير متجاور الأعمدة

إلى مدى متصل الأعمدة

المشكلة عندى برقم الصف

هو هنا رقم ثابت = 1000

و أنا أريده متغيرا برقم آخر صف

و هو

Lr

انظر

Dim Lr As Long

  Lr = Range("b" & Rows.Count).End(xlUp).Row


 Range("b5:f1000,k5:m1000, g5:h1000").Copy


' Range("b5:f" & Lr), ("k5:m" & Lr), ("g5:h" & Lr).Copy


       Sheets("41").Range("b6").PasteSpecial Paste:=xlPasteColumnWidths

        Sheets("41").Range("b6").PasteSpecial Paste:=xlPasteValues

        Sheets("41").Range("b6").PasteSpecial Paste:=xlPasteFormats

السطر هذا

Range("b5:f1000,k5:m1000, g5:h1000").Copy

أدى المهمة لكن رقم الصف كما ترى ثابت من 5 إلى 1000 أنا أريد وضع المتغير Lr الذى يشير لآخر صف مكان ال 1000 جربت ما تحته خط لم ينفع السطر هذا

Range("b5:f" & Lr), ("k5:m" & Lr), ("g5:h" & Lr).Copy

لم يعمل معى

كيف أصوغه بشكل سليم

تم تعديل أغسطس 28, 2010 بواسطه kemas

[عبد الفتاح كيرة]

الحمد لله يا معلم

توصلت لهذا و عمل بنجاح

Union(Range("b5:f" & Lr), Range("k5:m" & Lr), Range("g5:h" & Lr)).Copy

فما تفسير هذا

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

السلام عليكم

Union

غرض Range يمثل اجتماع مجموعة نطاقات متجاورة او غير متجاورة

[houudaa]

السلام عليكم

أستاذي الكريم/جبور

لا شلت يمينك

بس ممكن سؤال هل من الممكن تغير الاسماء والمناطق الموضوعه في الجدول؟؟

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

وعليكم السلام

بس ممكن سؤال هل من الممكن تغير الاسماء والمناطق الموضوعه في الجدول؟؟

نعم

بس ضبط المعلومات في اول الكود تمام

'======================================================

'  اول صف للتقرير

Private Const iRow As Integer = 4

'------------------------------------------------------

'  اسم ورقة التقارير

Private Const Sh_Report As String = "التقرير"

'------------------------------------------------------

'  اسم ورقة البيانات

Private Const Sh_MyDate As String = "بيانات اساسية"

'------------------------------------------------------

'  تعيين نطاق الخلايا في ورقة البيانات

'        ويشمل رؤوس الاعمدة

Private Const MyRng_MyDate As String = "A5:X1000"

'======================================================

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

السلام عليكم

Sub kh_tr_2()

Dim X As Range

Dim C As Byte, CC As Byte

Dim IRow As Integer

IRow = 2

IRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & IRow, Title:="ادراج عدد محدد من صفوف ", Default:=IRow, Type:=1)

If IRow = False Then Exit Sub

Sheets("KH").Cells.ClearContents

For C = 1 To 9

    CC = Choose(C, 1, 2, 3, 6, 7, 8, 13, 17, 18)

    With Range("A1:X" & IRow)

        If X Is Nothing Then Set X = .Columns(CC) Else _

            Set X = Union(X, .Columns(CC))

    End With

Next

If Not X Is Nothing Then

    X.Copy

    Sheets("KH").Select

    Range("A1").PasteSpecial xlPasteValues

    Application.CutCopyMode = False

    Range("A1").Select

End If

End Sub

شاهد المرفق

ترحيل مدى غير متجاور.rar

[عبد الفتاح كيرة]

السلام عليكم

---

نواصل العمل :

----

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

عملية توزيع الطلاب على الفصول

للعام الجديد

يدويا و على أرض الواقع

يكتب أمام كل طالب مجموع درجاته فى العام المنصرم

ثم يؤبتث ( يعنى يؤبجد - يرتب ) الطلاب حسب المجموع

الأعلى ثم الأقل و هكذا

مثلا نريد التوزيع على أربعة فصول

فنبدأ بالكتابة أمام الكشف المرتب حسب المجموع

1

2

3

4

ثم نكرر

1

2

3

4

وهكذا حتى آخر طالب

نقلت ذلك إلى الإكسل

و استخدمت كود لترتيب الطلاب حسب مجموعهم

يرتب حسب عمود المجموع

ثم حسب المحولين من المدرسة

ثم وظيفة لتنفيذ ما سبق

ثم كود لإعادة ترتيب الطلاب كما كانوا حسب الاسم

هذه هى الوظيفة

Sub tawz()

Application.ScreenUpdating = False

Dim i As Integer, mm As Integer

'عدد الفصول بشيت data

 mm = Sheets("الرئيسة").Range("f10").Value

'ماكرو للفرز حسب حول إلى مدرسة ثم حسب المجموع لحصر المحولين متتاليين

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

Call sort5

Sheets("all").Activate

'تنظيف المكان قبل العمل

Range("ab5:ab1000").ClearContents

'تحديد أو خلية للفصل

Range("ab5").Activate

'اعمل مادام خانة الاسم ليست فارغة

Dim LR2 As Long

LR2 = Sheets("all").Range("b" & Rows.Count).End(xlUp).Row

Dim ww As Long

Dim q As Integer

For ww = 1 To Int(LR2 / mm)

    For i = 1 To mm

        If Range("ab" & i + 4 + q).Offset(0, -5).Value = "" And Range("b" & i + 4 + q).Value <> "" Then

        Cells(i + 4 + q, 28).Value = i

        End If

    Next i

q = q + mm

Next ww

'أعد الترتيب الأبجدى

Call abc

Application.ScreenUpdating = True

Application.CutCopyMode = False

Sheets("class").Select

Range("a5").Select

' رأس و تذييل الصفحة

 With Sheets("class").PageSetup

                    '.LeftHeader = "&""-,غامق""&12كشف رقم  : &P"

                     .LeftFooter = "&""-,غامق""&16مدير المدرسة" & " / " & Sheets(1).Range("f7")

                     .RightFooter = "&""-,غامق""&16وكيل ش ط" & " / " & Sheets(1).Range("f8")

                     '.RightFooter = "&""-,غامق""&16اللجنة :"

End With

End Sub

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

Sub abc()

'

' abc ماكرو

'

Dim LR2 As Long

LR2 = Sheets("all").Range("b" & Rows.Count).End(xlUp).Row


'

    Sheets("All").Select

    Range("b5:AE" & LR2).Select

    ActiveWorkbook.Worksheets("All").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("All").Sort.SortFields.Add Key:=Range("B5:B" & LR2), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("All").Sort

        .SetRange Range("b5:AE" & LR2)

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

   Range("B5").Select

End Sub

[عبد الفتاح كيرة]

و هذا يفرز أيضا حسب عمود المحولين

ثم حسب عمود المجموع

Sub sort5()

 Dim LR2 As Long

 LR2 = Sheets("all").Range("b" & Rows.Count).End(xlUp).Row


    Range("b4:AE" & LR2).Select

    ActiveWorkbook.Worksheets("All").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("All").Sort.SortFields.Add Key:=Range("o4:O" & LR2), _

        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("All").Sort

        .SetRange Range("b4:AE" & LR2)

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

     Range("B4:AE" & LR2).Select

  ActiveWorkbook.Worksheets("All").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("All").Sort.SortFields.Add Key:=Range("W4:W" & LR2), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("All").Sort

        .SetRange Range("B4:AE" & LR2)

        .Header = xlYes

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

End Sub

السؤال

هل هناك طريقة أفضل لتوزيع الفصول

مرفق ملف

توزيع الفصول.zip

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

السلام عليكم

الاخ الفاضل / كيماس _________حفظه الله

شاهد الرابط التالي:

توزيع الفصول باختيار النوع (ولد او بنت) او مشترك وبميزة تساوي الدرجات

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

[قصي]

الاستاذ خبور المحترم

اعانني الله في نقل كودكم المفيد في هذا المرفق ولكن يحتاج منكم

تعديل

لاني لم اعرف اين الجزئيه المطلوب تغييرها

فلو حولت هذا الكود بطريقتك السهله

ليكون سهلا عند نقله وتغيير المواقع

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

إعداد تقارير مدرسية بنموذج ادخال.rar

[قصي]

لو تكرمتم اريد نموذج الادخال يعمل

كان يعمل مع عندما كان الصف يبدأ من الصف الاول

وعندما تغير الصف اصبح بهذه الصوره

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

السلام عليكم

فلو حولت هذا الكود بطريقتك السهله

ليكون سهلا عند نقله وتغيير المواقع

غير هنا

'******************************************************

'  اسم ورقة البيانات

Const Sh_MyDate As String = "بيانات اساسية"

'------------------------------------------------------

'  رقم صف رؤوس الاعمدة

Const lrow As Integer = 5

'------------------------------------------------------

'  عدد الاعمدة التي تريدها ابتداءا من العمود الاول

Const lcol As Integer = 28

'******************************************************

تفضل المرفق

اعداد تقارير مدرسية.rar

[cat101]

عالي المقام

اضافه بسيطه منكم تجعل الملف خرافي

الصف الاول مكن ان يكون صفين او ثلاثه

ماهو الحل ؟

المرفق يوضح اكثر

تقرير بنموذج ادخال .خبور.rar

[عبد الفتاح كيرة]

أخ cat101

دمج الخلايا هو العدو الأول للأكواد

احفظ هذا عنى

ولا أرى لدمج الخلايا هنا فائدة

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

بدلا من الدمج

والكود يلصقها بنفس عرضها

والله أعلم