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

commandos1975 · ديسمبر 28, 2012

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

classes.rar

**دغيدى** · ديسمبر 28, 2012

أخى الكريم

الملف محمى ..برجاء ازالة الحماية

**يوسف عطا** · ديسمبر 28, 2012

صباح الخيرات أخونا الغالى جمال بك

تقبل تحياتى

**يوسف عطا** · ديسمبر 28, 2012

أخى كوماندوز

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

كود الترحيل للفصول من شيت السجل يرحل لعدد 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

**دغيدى** · ديسمبر 28, 2012

أخى اكريم

تفضل

وحتى 50 فصلا كل فصل 60 طالبا

classes 2.rar

**بن علية حاجي** · ديسمبر 28, 2012

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

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

أخوكم بن علية

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

commandos1975 · ديسمبر 28, 2012

بارك اله فيكم جميعا منتدي في غاية الجمال

اريد ان تكون الفصول في نفس الصفحة حتي تسهل الطباعة

منياوى · ديسمبر 28, 2012

اكثر من رائع جزاكم الله خيرا

**أبو محمد عباس** · ديسمبر 28, 2012

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

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

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

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

**بن علية حاجي** · ديسمبر 28, 2012

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

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

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

أخوكم بن علية

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

**أبو محمد عباس** · ديسمبر 29, 2012

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

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

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

تسجيل الدخول

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

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

commandos1975

دغيدى

يوسف عطا

يوسف عطا

دغيدى

بن علية حاجي

commandos1975

منياوى

أبو محمد عباس

بن علية حاجي

أبو محمد عباس

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information