طارق محمود

السلام عليكم تفضل المرفق empmm.zip

السلام عليكم إرسل أخي رسلان ماتشاء وستجد الجميع معك إن شاء الله

الأخت الفاضلة / أم عبد الله جزاكي الله خيرا علي مرورك الطيب وكلماتك الرقيقة

السلام عليكم أخي الفاضل / ابوملك الكود بعد التعديل (4 فصول) Sub Rnd_3_Col() Dim boy(999) As String, grl(999) As String, slct(999) As Integer Application.ScreenUpdating = False ' Read data b = 0: g = 0 LR = [B65536].End(xlUp).Row Range("D7:G" & LR).ClearContents For r = 7 To LR If Cells(r, 3) = "أ" Then g = g + 1: grl(g) = Cells(r, 2) ElseIf Cells(r, 3) = "ذ" Then b = b + 1: boy(b) = Cells(r, 2) End If Next r TN = b + g Randomize s = 0 ' s for selected For col = 4 To 6 ' Column D,E & F For i = 1 To TN / 4 10 x = Int(Rnd * TN) + 1 For ch = 1 To s If slct(ch) = x Then GoTo 10 Next ch s = s + 1: slct(s) = x ready_row = Cells(999, col).End(xlUp).Row + 1 If x > g Then x = x - g: dd = boy(x) Else dd = grl(x) Cells(ready_row, col).Value = dd Next i Next col ' Column G For i = 1 To TN For ch = 1 To s If slct(ch) = i Then GoTo 20 Next ch ready_row = Cells(999, 7).End(xlUp).Row + 1 If i > g Then x = i - g: dd = boy(x) Else dd = grl(i) Cells(ready_row, 7).Value = dd 20 Next i Application.ScreenUpdating = True End Sub والملف مرفق بعد التعديل (4 فصول) توزيع التلاميذ5.rar

السلام عليكم أخي الفاضل / ابوجادالله سأبدأ بالنقطة الثانية عندك حق ، وقد عدلت الكود كما يلي Sub Rnd_3_Col() Dim boy(999) As String, grl(999) As String, slct(999) As Integer Application.ScreenUpdating = False ' Read data b = 0: g = 0 LR = [B65536].End(xlUp).Row Range("D7:F" & LR).ClearContents For r = 7 To LR If Cells(r, 3) = "أ" Then g = g + 1: grl(g) = Cells(r, 2) ElseIf Cells(r, 3) = "ذ" Then b = b + 1: boy(b) = Cells(r, 2) End If Next r TN = b + g Randomize s = 0 ' s for selected For col = 4 To 5 ' Column D & E For i = 1 To TN / 3 10 x = Int(Rnd * TN) + 1 For ch = 1 To s If slct(ch) = x Then GoTo 10 Next ch s = s + 1: slct(s) = x ready_row = Cells(999, col).End(xlUp).Row + 1 If x > g Then x = x - g: dd = boy(x) Else dd = grl(x) Cells(ready_row, col).Value = dd Next i Next col ' Column F For i = 1 To TN For ch = 1 To s If slct(ch) = i Then GoTo 20 Next ch ready_row = Cells(999, 6).End(xlUp).Row + 1 If i > g Then x = i - g: dd = boy(x) Else dd = grl(i) Cells(ready_row, 6).Value = dd 20 Next i Application.ScreenUpdating = True End Sub وبالمرفق ستجد أن هذه النقطة قد إنضبطت مهما كان عدد الطلبة والطالبات اما النقطة الأولي التغيرات الذى تقوم به فى الكود حتى يتم التوزيع على سبع فصول مثلا فيلزمك عدة تغيرات في الكود (1) ستغير الرقم 3 إلي 7 في السطر : For i = 1 To TN / 3 ليكون For i = 1 To TN / 7 (2) وتغير أرقام الأعمدة التي ستتلقي البيانات في السطر السابق له For col = 4 To 5 ' Column D & E ليكون For col = 4 To 9 ' Column D to I (3) وتغير رقم العمود الأخير لتلقي البيانات في الجزء الأخير من الكود ' Column F For i = 1 To TN For ch = 1 To s If slct(ch) = i Then GoTo 20 Next ch ready_row = Cells(999, 6).End(xlUp).Row + 1 If i > g Then x = i - g: dd = boy(x) Else dd = grl(i) Cells(ready_row, 6).Value = dd 20 Next i ليكون ' Column J For i = 1 To TN For ch = 1 To s If slct(ch) = i Then GoTo 20 Next ch ready_row = Cells(999, 10).End(xlUp).Row + 1 If i > g Then x = i - g: dd = boy(x) Else dd = grl(i) Cells(ready_row, 10).Value = dd 20 Next i (4) وأخيرا ، تغير رقم المجال الذي يتم مسحه في بدايات الكود من Range("D7:F" & LR).ClearContents إلي Range("D7:I" & LR).ClearContents توزيع التلاميذ4.rar

السلام عليكم أخي الفاضل / shakhawan تفضل المرفق توزيع التلاميذ3.rar

أخي الكريم كما تفضل أخونا الغالي / ابو اياد فإن أولا :طلبك كبير ثانيا: للأسف ليس لدي وقت ولاأعتقد أن من الأخوة من سيكون لديه مثل هذا الوقت لذلك أنصحك (وباقي الأعضاء الجدد) بالآتي إبحث في المنتدي (وستجد بس لازم تبحث) عن ملف يكون أقرب مايكون لما تريد قسًم باقي الطلبات (التي لم تجدها بالملف) لمواضيع مختلفة ، أي إجعل لكل طلب موضوع منفصل وكل موضوع تضع معه فقط نقطة واحدة أو مشكلة واحدة أو إثنين علي الأكثر إن شاء الله ستجد ردود سريعة وكثيرة ومتنوعة ، تختار مايناسبك وتجمع انت بنفسك الملف كله مرة أخري وكخطوة أولي : بحثت لك ستجد في هذا الموضوع http://www.officena.net/ib/index.php?showtopic=46420&page=11&hl=%D8%A8%D8%A7%D8%B1%D9%83%D9%88%D8%AF#entry291551 طريقة عمل فورم فاتورة ووضع اكوادها وترحيلها واستدعائها وطباعتها !! خطوة خطوة وهذا موضوع بعنوان معادلة للتكويد ( عمل باركود ) http://www.officena.net/ib/index.php?showtopic=46677&hl=

السلام عليكم أخي العزيز بعد إذن أخي بن علية وأخي عباس حسب ما أعلم فلاينبغي أن تطول المعادلة عن 256 حرف (بما فيها =) لذلك وكما نصحك الإخوة ، إبحث دائما عن الحل الأقصر وفي هذا السياق ، إليك أيضا الحل بدالة Vlookup حساب النقاط2.rar

السلام عليكم يمكن عمل ذلك في خطوتين (1) إحفظ بإسم Save As csv ليحفظ الملف بفاصلة بين كل عمود بيانات (2) من محرر التيكست (مثلا Notepad) إستبدل (Ctrl-H) كل فاصلة بـ مسافة (, >> )

السلام عليكم تفضل المرفق توزيع التلاميذ2.rar

إرسل الملف الإكسل

لم أفهم قصدك من الملاحظة "لم يتم الفرز فى القادمين عند الترحيل الا بعد الكتابه فى h7 وليس الترحيل" أيضا كود اللغة (عربي / إنجليزي) يحتاج وقت لتتبعه وليس عندي (أعتذر منك) تم بالمرفق عمل الكود والزر لحذف البيانات فقط بالشيتات المطلوبة k1_2.rar

السلام عليكم حلها بسيط إن شاء الله بالخطوتين التاليتين (1) السطر الذي تم تعديله من قبل LR = .[b35].End(xlUp).Row ضع بعده مباشرة الأمر التالي If LR = 4 Then GoTo 10 (2) في آخر الكود ضع الرقم 10 قبل Next j ليكون الكود كله كالتالي Sub tarheel() Dim sh(9) mysh = "عام" sh(1) = "الاتوبيس": sh(2) = "طائرة": sh(3) = "مطروح": sh(4) = "نعديل" For i = 1 To Sheets.Count For j = 1 To 4 If Sheets(i).Name = sh(j) Then With Sheets(i) LR = .[B35].End(xlUp).Row If LR = 4 Then GoTo 10 dt = Format(.[F3], "dd-mm-yyyy") With .Range("B5:H" & LR) s = .Rows.Count .Copy End With End With Sheets(mysh).Activate nr = [I99999].End(xlUp).Row + 1 Cells(nr, "I").PasteSpecial Paste:=xlPasteValues Range("H" & nr & ":H" & nr + s - 1) = dt Range("P" & nr & ":P" & nr + s - 1) = sh(j) sh(j) = "finish" End If 10 Next j Next i End Sub أو تفضل المرفق مانفست كلابشة_Ali4.rar

إضغط الفولدر بملفاته وأرسله وإن كان به اي بيانات خاصة ، إمسحها أولا وإن حجمه كبير ، إرسل لي علي الخاص tarekmahmoud_2@hotmail.com

السلام عليكم أخي العزيز إستبدل السطر LR = .[b5].End(xlDown).Row بالتالي LR = .[b35].End(xlUp).Row ليكون الكود كالتالي Sub tarheel() Dim sh(9) mysh = "عام" sh(1) = "الاتوبيس": sh(2) = "طائرة": sh(3) = "مطروح": sh(4) = "نعديل" For i = 1 To Sheets.Count For j = 1 To 4 If Sheets(i).Name = sh(j) Then With Sheets(i) LR = .[B35].End(xlUp).Row dt = Format(.[F3], "dd-mm-yyyy") With .Range("B5:H" & LR) s = .Rows.Count .Copy End With End With Sheets(mysh).Activate nr = [I99999].End(xlUp).Row + 1 Cells(nr, "I").PasteSpecial Paste:=xlPasteValues Range("H" & nr & ":H" & nr + s - 1) = dt Range("P" & nr & ":P" & nr + s - 1) = sh(j) sh(j) = "finish" End If Next j Next i End Sub أو تفضل المرفق مانفست كلابشة_Ali3.rar

السلام عليكم أخي الكريم الملف لايعمل لأننا عطلنا السطر كما سبق On Error Resume Next' فقط إلغي الأبوستروف ليعود كما كان

السلام عليكم أخي العزيز جرب الكود التالي Sub tarheel() Dim sh(9) mysh = "عام" sh(1) = "الاتوبيس": sh(2) = "طائرة": sh(3) = "مطروح": sh(4) = "نعديل" For i = 1 To Sheets.Count For j = 1 To 4 If Sheets(i).Name = sh(j) Then With Sheets(i) LR = .[B5].End(xlDown).Row dt = Format(.[F3], "dd-mm-yyyy") With .Range("B5:H" & LR) s = .Rows.Count .Copy End With End With Sheets(mysh).Activate nr = [I99999].End(xlUp).Row + 1 Cells(nr, "I").PasteSpecial Paste:=xlPasteValues Range("H" & nr & ":H" & nr + s - 1) = dt Range("P" & nr & ":P" & nr + s - 1) = sh(j) sh(j) = "finish" End If Next j Next i End Sub أو تفضل الملف مرفقا مانفست كلابشة_Ali2.rar

السلام عليكم هذا الأمر يغير إسم الملف الأصلي nm الذي في المسار pt إلي الإسم tempo2.xls الذي في المسار pt أيضا وهذا في إعتقادي لايعطي خطأ إلا إذا 1- كان الملف nm غير موجود (بالفعل تم تغيير إسمه قبل هذه الخطوة) 2- كان الملف nm مفتوح ولن أستطيع التقرير ، أنت الذي تقرر سبب الخطأ ، تقول فعليك ملاحظة في أي الحالات بالضبط وأيضا إرسل لي صورة من الرسالة التي يعطيها مع الخطأ

لا أدري ولكن يمكنك إيقاف تفعيل اول أمر في الكود بعمل ' أبوستوف قبله هكذا On Error Resume Next' وبعد إيقاف تفعيل هذا الأمر ، لن يتجاوز عن الخطأ وسيقف عند الخطأ ويضع عنده لون أصفر (في الكود) مما سيعطيك فرصة لفهم السبب أو تنقل لنا أين الخطأ بعد تلوينه بالأصفر

أخي الكريم / علي حسن بارك الله فيك وفيمن تحب ورزقكم الخير كله

أعتقد السبب في إعدادات الأوفيس أو الويندوز

السلام عليكم أخي الكريم طبعا ممكن ذلك إن أردت إرسل البيانات

أخي العزيز/ أبو ناصر السلام عليكم تجد ملفك مفكوك الحماية علي رابط أرسلته لك علي الإميل

السلام عليكم بالإضافة لحل أخونا الغالي / قنديل ولإثراء الموضوع فقد فكرت ، لو إستعملنا الجداول المحورية في مثل هذه الحالة ، ستعطينا خيارات كثيرة ومتعددة أولا ننسخ الورقة في ورقة أخري ثم نلغي الفراغات بين الصفوف والأعمدة ثم تكون جدول محوري وتشارت محورية الفائدة : يمكنك حذف وإعادة أي عنصر من عناصر الرسم البياني (تشارت) مثلا بالمرفق حذفت الفروع كلها فيما عدا M,D وكذلك حذفت الربع الأول والرابع من الرسم فيمكنك مقارنتهما بصورة أفضل وإستخراج العديد من التقارير والرسومات برسم واحد ستجد في أسفل الرسم زرين بعنوان PERIOD , BRANCHES إفتح أي منهما وحدد الفروع التي تريد (أو كلها) وكذلك المدد التي تريد (أو كلها) بالإضافة إلي ذلك ،يمكنك التحكم من الجدول المحوري نفسه في خيارات أفضل أتركك مع المرفق COMPARISON2.rar

السلام عليكم تفضل المرفق لابد أن يكون الملفين مفتوحين ABCD_1.rar