اذهب الي المحتوي
أوفيسنا

عمل قوائم فصول


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

قام أحد الزملاء بهذا العمل وقمت بالتعديل لزيادة عدد تلاميذ الفصل برجاْ طريقة زيادة عدد الفصول حيث ان المجود هو 4 فصول اريد زيادها حتي 12 فصل

classes.rar

رابط هذا التعليق
شارك

أخى كوماندوز

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

كود الترحيل للفصول من شيت السجل يرحل لعدد 22 فصل وكل فصل 60 طالب

كما يخرج إحصاء بعدد الطلبة فى كل فصل

ويستخرج إحصاء بطلاب الفصل الواحد حسب الديانة وحالة القيد

أتمنى يحقق مرادك


Sub ترحيل_فصول()

Dim Z As Integer, A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer, G As Integer, H As Integer, I As Integer, J As Integer, K As Integer, L As Integer, M As Integer, N As Integer, O As Integer, P As Integer, Q As Integer, R As Integer, S As Integer, T As Integer, U As Integer, V As Integer

Sheets("1").Range("A7:DZ5000").ClearContents

Sheets("2").Range("A7:DZ5000").ClearContents

Sheets("3").Range("A7:DZ5000").ClearContents

Sheets("4").Range("A7:DZ5000").ClearContents

Sheets("5").Range("A7:DZ5000").ClearContents

Sheets("6").Range("A7:DZ5000").ClearContents

Sheets("7").Range("A7:DZ5000").ClearContents

Sheets("8").Range("A7:DZ5000").ClearContents

Sheets("9").Range("A7:DZ5000").ClearContents

Sheets("10").Range("A7:DZ5000").ClearContents

Sheets("11").Range("A7:DZ5000").ClearContents

Sheets("12").Range("A7:DZ5000").ClearContents

Sheets("13").Range("A7:DZ5000").ClearContents

Sheets("14").Range("A7:DZ5000").ClearContents

Sheets("15").Range("A7:DZ5000").ClearContents

Sheets("16").Range("A7:DZ5000").ClearContents

Sheets("17").Range("A7:DZ5000").ClearContents

Sheets("18").Range("A7:DZ5000").ClearContents

Sheets("19").Range("A7:DZ5000").ClearContents

Sheets("20").Range("A7:DZ5000").ClearContents

Sheets("21").Range("A7:DZ5000").ClearContents

Sheets("22").Range("A7:DZ5000").ClearContents

A = 7: B = 7: C = 7: D = 7: E = 7: F = 7: G = 7: H = 7: I = 7: J = 7: K = 7: L = 7: M = 7: N = 7: O = 7: P = 7: Q = 7: R = 7: S = 7: T = 7: U = 7: V = 7

Application.ScreenUpdating = False

For Z = 2 To 5000

If Cells(Z, 5) = "1" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("1").Range("A" & A).PasteSpecial xlPasteValues

Application.CutCopyMode = False

A = A + 1

End If

If Cells(Z, 5) = "2" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("2").Range("A" & B).PasteSpecial xlPasteValues

Application.CutCopyMode = False

B = B + 1

End If

If Cells(Z, 5) = "3" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("3").Range("A" & C).PasteSpecial xlPasteValues

Application.CutCopyMode = False

C = C + 1

End If

If Cells(Z, 5) = "4" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("4").Range("A" & D).PasteSpecial xlPasteValues

Application.CutCopyMode = False

D = D + 1

End If

If Cells(Z, 5) = "5" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("5").Range("A" & E).PasteSpecial xlPasteValues

Application.CutCopyMode = False

E = E + 1

End If

If Cells(Z, 5) = "6" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("6").Range("A" & F).PasteSpecial xlPasteValues

Application.CutCopyMode = False

F = F + 1

End If

If Cells(Z, 5) = "7" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("7").Range("A" & G).PasteSpecial xlPasteValues

Application.CutCopyMode = False

G = G + 1

End If

If Cells(Z, 5) = "8" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("8").Range("A" & H).PasteSpecial xlPasteValues

Application.CutCopyMode = False

H = H + 1

End If

If Cells(Z, 5) = "9" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("9").Range("A" & I).PasteSpecial xlPasteValues

Application.CutCopyMode = False

I = I + 1

End If

If Cells(Z, 5) = "10" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("10").Range("A" & J).PasteSpecial xlPasteValues

Application.CutCopyMode = False

J = J + 1

End If

If Cells(Z, 5) = "11" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("11").Range("A" & K).PasteSpecial xlPasteValues

Application.CutCopyMode = False

K = K + 1

End If

If Cells(Z, 5) = "12" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("12").Range("A" & L).PasteSpecial xlPasteValues

Application.CutCopyMode = False

L = L + 1

End If

If Cells(Z, 5) = "13" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("13").Range("A" & M).PasteSpecial xlPasteValues

Application.CutCopyMode = False

M = M + 1

End If

If Cells(Z, 5) = "14" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("14").Range("A" & N).PasteSpecial xlPasteValues

Application.CutCopyMode = False

N = N + 1

End If

If Cells(Z, 5) = "15" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("15").Range("A" & O).PasteSpecial xlPasteValues

Application.CutCopyMode = False

O = O + 1

End If

If Cells(Z, 5) = "16" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("16").Range("A" & P).PasteSpecial xlPasteValues

Application.CutCopyMode = False

P = P + 1

End If

If Cells(Z, 5) = "17" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("17").Range("A" & Q).PasteSpecial xlPasteValues

Application.CutCopyMode = False

Q = Q + 1

End If

If Cells(Z, 5) = "18" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("18").Range("A" & R).PasteSpecial xlPasteValues

Application.CutCopyMode = False

R = R + 1

End If

If Cells(Z, 5) = "19" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("19").Range("A" & S).PasteSpecial xlPasteValues

Application.CutCopyMode = False

S = S + 1

End If

If Cells(Z, 5) = "20" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("20").Range("A" & T).PasteSpecial xlPasteValues

Application.CutCopyMode = False

T = T + 1

End If

If Cells(Z, 5) = "21" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("21").Range("A" & U).PasteSpecial xlPasteValues

Application.CutCopyMode = False

U = U + 1

End If

If Cells(Z, 5) = "22" Then

Range("A" & Z).Resize(1, 22).Copy

Sheets("22").Range("A" & V).PasteSpecial xlPasteValues

Application.CutCopyMode = False

V = V + 1

End If

Next

For Y = 1 To 22

Sheets(Y).[a7] = 1

rrw = Sheets(Y).[A3000].End(xlUp).Row

For Each cc In Sheets(Y).Range("a8:A" & rrw)

cc.Value = cc.Offset(-1, 0) + 1

Next cc

Next Y

MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى فصلها طبقاً للإحصاء التالى ")

For X = 1 To 22

Y = Sheets(X).[A3000].End(xlUp).Row - 6

mssg = mssg & Chr(10) & Format(Y, "00") & " طالبة بفصل رقم : " & X

Sheets(X).Select

Range("A37:S100").Copy

Range("G7").Select

ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats

Range("A37:F100").ClearContents

Range("M1:S3").Select

Selection.Copy

Range("C38").Select

ActiveSheet.Paste

Range("A1").Select

Application.CutCopyMode = False

Next X

MsgBox (" تم ترحيل عدد" & mssg)

Range("A1").Select

Application.ScreenUpdating = True

End Sub

قوائم فصول22 فصل.rar

رابط هذا التعليق
شارك

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

أخي الكريم، تجد في الملف المرفق تبسيطا واختصارا لنص كود أخي الكريم "يوسف عطا" جازاه الله عنا خير الجزاء...

أخوكم بن علية

قوائم فصول22 فصل.rar

رابط هذا التعليق
شارك

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

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

الاخ commandos 1975 بالنسبة لسؤالك في المشاركة 7 ان تكون الفصول في صفحة واحدة اعتقد يوجد حل في هذا الرابط للاستاذ محمود جزاه الله خيرا

http://www.officena....howtopic=44632#

رابط هذا التعليق
شارك

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

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

أرجو أن يكون العمل مستوفيا المطلوب...

أخوكم بن علية

قوائم الفصول.rar

رابط هذا التعليق
شارك

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

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

ودمتم في رعاية الله وحفظه

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information