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

**عبدالله باقشير** · أغسطس 26, 2010

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

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

ملحوظة :

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

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

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

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

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

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

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

**عبدالله باقشير** · أغسطس 26, 2010

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

حلول الأساتذة لمنع مسح المعادلات :
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

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

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

خبور خير

**عبد الفتاح كيرة** · أغسطس 26, 2010

السلام عليكم

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

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

المشكلة

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

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

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

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

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

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

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

وبعد ذلك

وجدت طريقتك

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

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

ثانيا

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

فقل رأيك فيه

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

**عبدالله باقشير** · أغسطس 26, 2010

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

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

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

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

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

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

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

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

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

Const Sh_MyDate As String = "all"

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

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

Const lrow As Integer = 3

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

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

Const lcol As Integer = 60

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

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

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

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

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

شاهدي المرفق

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

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

**عبد الفتاح كيرة** · أغسطس 26, 2010

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

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

UserForm1.Show vbModeless

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

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

**عبد الفتاح كيرة** · أغسطس 27, 2010

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

MsgBox "Hello" & vbCr & Application.UserName

**عبدالله باقشير** · أغسطس 27, 2010

السلام عليكم

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

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

ان اردت ذلك ؟؟

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

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

خبور خير

**عبد الفتاح كيرة** · أغسطس 27, 2010

السلام عليكم

لنعد للعمل :

---

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

مثلا

a1:c100

و

f1:h100

و

m1:m100

و

q1:r100

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

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

لدى سؤالان

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

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

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

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

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

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

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

-------

مع الشكر

**عبدالله باقشير** · أغسطس 27, 2010

السلام عليكم

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

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

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

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

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

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

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

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

**عبد الفتاح كيرة** · أغسطس 27, 2010

طيب زين

اقتربنا

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

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

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

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

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

**عبدالله باقشير** · أغسطس 27, 2010

السلام عليكم

هذا إذا كان المدى صفه محددا
كيف نكتبه إذا كان رقم الصف الثانى الذى هو = 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

**عبد الفتاح كيرة** · أغسطس 28, 2010

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

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

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

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

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

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

هو هنا رقم ثابت = 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

**عبد الفتاح كيرة** · أغسطس 28, 2010

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

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

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

فما تفسير هذا

**عبدالله باقشير** · أغسطس 28, 2010

السلام عليكم

Union

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

houudaa · أغسطس 28, 2010

السلام عليكم

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

لا شلت يمينك

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

**عبدالله باقشير** · أغسطس 28, 2010

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

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

نعم

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

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

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

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"

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

**عبدالله باقشير** · أغسطس 28, 2010

السلام عليكم

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

**عبد الفتاح كيرة** · أغسطس 28, 2010

السلام عليكم

---

نواصل العمل :

----

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

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

للعام الجديد

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

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

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

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

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

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

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

**عبد الفتاح كيرة** · أغسطس 29, 2010

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

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

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

**عبدالله باقشير** · سبتمبر 9, 2010

السلام عليكم

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

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

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

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

**قصي** · سبتمبر 11, 2010

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

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

تعديل

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

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

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

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

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

**قصي** · سبتمبر 13, 2010

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

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

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

**عبدالله باقشير** · سبتمبر 18, 2010

السلام عليكم

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

غير هنا

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

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

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

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

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

Const lrow As Integer = 5

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

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

Const lcol As Integer = 28

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

تفضل المرفق

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

cat101 · أكتوبر 22, 2010

عالي المقام

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

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

ماهو الحل ؟

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

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

**عبد الفتاح كيرة** · أكتوبر 22, 2010

أخ cat101

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

احفظ هذا عنى

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

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

بدلا من الدمج

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

والله أعلم

تسجيل الدخول

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

الردود الموصى بها

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

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

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

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

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information