رجب جاويش

أخى الفاضل / يوسف عطا تفضل أخى سيكون التعديل بالشكل التالى For Y = 24 To 26 Sheets(Sheet & Y).[B11] = 1 rrw = Sheets(Sheet & Y).[B3000].End(xlUp).Row For Each cc In Sheets(Sheet & Y).Range("B12:B" & rrw) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next Y MsgBox ("الحمد لله تـــم ترحيل الطالبات كل إلى شيت نتيجتها طبقاً للإحصاء التالى ") For x = 24 To 26 Y = Sheets(Sheet & x).[B3000].End(xlUp).Row - 10 mssg = mssg & Chr(10) & Format(Y, "00") & " Students to Sheet : " & x Next x MsgBox (" تم ترحيل عدد" & mssg) Range("A1").Select Application.ScreenUpdating = True End Sub

أخى الفاضل / يوسف عطا بالنسبة للجزء التالى من الكود For y = 24 To 26 فهو يتعامل مع رقم الشيت المجاور لكلمة sheet وليس الرقم الموجود بين القوسين كما فى الصورة المرفقة وعند تغيير الأرقام لتناسب الموجود بجوار كلمة sheet فان الكود يعمل تمام ان شاء الله

أخى الفاضل / حسين جرب هذا التعديل وان شاء الله يكون هو ما تريد حسين.rar

أخى الفاضل / أحمد فؤاد العفو أخى بل نحن أخوة نتعلم من بعضنا البعض ومن أساتذة هذا الصرح الكبير مثل الأستاذ الكبير / عبد الله باقشير والأستاذ / الخالدى والاستاذ / عبد الله المجرب و غيرهم الكثير

أخى الفاضل / حسين هل تقصد أن يتم مسح البيانات الموجود فى الأعمدة J و K و L فى صفحة الترحيلات

بعد اذن أخى الفاضل /fzsss يمكن تجميع الخلايا المتفرقة من خلال هذا الكود Sub ragab() E = 4 For C = 6 To 26 For R = 1 To Cells(Rows.Count, C).End(xlUp).Row If Cells(R, C).Value <> Empty Then Cells(E, 4) = Cells(R, C) E = E + 1 End If Next Next End Sub وهو يعمل على تجميع الخلايا المتفرقة فى أى خلية من خلايا الأعمدة من F حتى Z ويمكن تغيرها ويقوم بعمل قائمة مرنة فى العمود D المخفى واستخدام هذه القائمة فى عمل قائمة الـ DATA VALIDATION المطلوبة قائمة منسدلة من عدة خلايا متفرقة.rar

أخى الفاضل / يوسف عطا بعد التحية يرجى وضع الملف الذى يطبق علية الكود لان ذلك يسهل معرفة مكان الخلل

يمكن تقسيم الملف الى جزئين ببرنامج winrar

أخى الفاضل / حسين جرب هذا الكود وأى تعديل تريده أخبرنى حسين.rar

أخى الفاضل /hussien2222 برجاء ارفاق ملف به كل التعديلات التى تريدها لزيادة التوضيح وان شاء الله يتم عمل المطلوب

أخى الفاضل / محمود رواس الكود يوضع فعلا فى حدث الصفحة وهو يعمل تلقائيا عند اضافة أو تغيير أى رقم فى المدى D5 : D23

تفضل أخى ابراهيم سيكون التعديل بالشكل التالى Sub ragab() Application.ScreenUpdating = False [G3:G20].ClearContents [F3:F20].ClearContents For i = 3 To 20 cl = Trim(Cells(i, 3)) x = UBound(Filter(Split(MyArr, ","), cl)) + 1 If x = 0 Then MyArr = MyArr & Trim(cl) & "," Next MyArr = Left(MyArr, Len(MyArr) - 1) For Each y In Split(MyArr, ",") Cells(Cells(Rows.Count, 6).End(xlUp).Row + 1, 6) = y Next For ii = 3 To 20 If Cells(ii, "F") <> "" Then Cells(ii, "G") = WorksheetFunction.SumIf(Range("C3:C20"), Cells(ii, "F"), Range("D3:D20")) End If Next Application.ScreenUpdating = True End Sub كود جمع2.rar

تفضل أخى ابراهيم Sub ragab() Application.ScreenUpdating = False [G3:G20].ClearContents For i = 3 To 20 If Cells(i, "F") <> "" Then Cells(i, "G") = WorksheetFunction.SumIf(Range("C3:C20"), Cells(i, "F"), Range("D3:D20")) End If Next Application.ScreenUpdating = True End Sub كود جمع1.rar

تفضل أخى بالنسبة للطلب الأول الكود موجود فى حدث الصفحة يعمل على جمع الخلايا حسب لونها ويعمل بمجرد كتابة أو تغيير أى رقم فى المدى D5 :D23 Private Sub Worksheet_Change(ByVal Target As Range) Dim cl As Range, cll As Range Dim x As Integer, xx As Integer '====================================================== If Not Intersect(Target, [D5:D23]) Is Nothing Then [G5:G8].ClearContents For Each cl In [G5:G8] For Each cll In [D5:D23] x = cll.Interior.ColorIndex xx = cl.Interior.ColorIndex If x = xx Then cl.Value = cl.Value + cll.Value End If Next Next End If End Sub أما بالنسبة للطلب الثانى هذه دالة معرفة تستخرج صيغة المعادلة بدلا من الناتج Function RG_sum(cl As Range) RG_val = Mid$(cl.Formula, 2) RG_sum = RG_val End Function وصيغة استخدامها =RG_sum(J19) الجمع بالالوان.rar

أخى الحبيب / أبو أنس حاجب السلام عليكم ورحمة الله وبركاته بارك الله فيك أخى الفاضل على الإضافة واللمسة الجميلة والحكم على على سرعة الكود يكون فى حالة البيانات الكبيرة كما جربت أنت ونجحت التجربة تسلم ايديك وتسلم أفكارك أخوك / رجب جاويش

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

الأستاذ الفاضل / احمد فضيله شكرا جزيلا على هذا المرور العطر وجزاك الله كل خير

أخى الفاضل / ريان أحمد شكرا جزيلا أخى الفاضل وجزاك الله كل خير

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

وهذا كود للترحيل التلقائى بمجرد كتابة رقم المجموعة فى العمود F Private Sub Worksheet_Change(ByVal Target As Range) Dim Sh As String, i As Integer '============================================ LR = [F10000].End(xlUp).Row Application.ScreenUpdating = False '=========================================================== If Not Intersect(Target, Range("F3:F" & LR)) Is Nothing Then Sheets("1").Range("A2:F1000").ClearContents Sheets("2").Range("A2:F1000").ClearContents Sheets("3").Range("A2:F1000").ClearContents '============================================ For i = 3 To LR Sh = Cells(i, 6).Value AA = Sheets(Sh).Cells(1000, 1).End(xlUp).Row + 1 On Error Resume Next Range(Cells(i, "A"), Cells(i, "F")).Copy Sheets(Sh).Range("A" & AA).PasteSpecial xlPasteValues Application.CutCopyMode = False Next i Application.ScreenUpdating = True End If End Sub employer3.rar

وهذا كود آخر يعتمد على تسمية الشيتات بنفس أسماء المجموعات أى 1 و 2 و 3 Sub ragab() Dim Sh As String, i As Integer '============================================ LR = [F10000].End(xlUp).Row Application.ScreenUpdating = False '============================================ Sheets("1").Range("A2:F1000").ClearContents Sheets("2").Range("A2:F1000").ClearContents Sheets("3").Range("A2:F1000").ClearContents '============================================ For i = 3 To LR Sh = Cells(i, 6).Value AA = Sheets(Sh).Cells(1000, 1).End(xlUp).Row + 1 On Error Resume Next Range(Cells(i, "A"), Cells(i, "F")).Copy Sheets(Sh).Range("A" & AA).PasteSpecial xlPasteValues Application.CutCopyMode = False Next i Application.ScreenUpdating = True End Sub employer2.rar

تفضل أخى Sub ragab() Dim i As Integer, x As Integer Dim LR As Integer, y As Integer, z As Integer '============================================================ LR = [F10000].End(xlUp).Row Application.ScreenUpdating = False '============================================================ Sheets("المجموعة الاولى").Range("A2:F1000").ClearContents Sheets("المجموعة الثانية").Range("A2:F1000").ClearContents Sheets("المجموعة الثالثة").Range("A2:F1000").ClearContents '============================================================ x = 2: y = 2: z = 2 For i = 3 To LR If Cells(i, 6).Value = 1 Then Range("A" & i).Resize(1, 6).Copy Sheets("المجموعة الاولى").Range("A" & x).PasteSpecial xlPasteValues x = x + 1 ElseIf Cells(i, 6).Value = 2 Then Range("A" & i).Resize(1, 6).Copy Sheets("المجموعة الثانية").Range("A" & y).PasteSpecial xlPasteValues y = y + 1 ElseIf Cells(i, 6).Value = 3 Then Range("A" & i).Resize(1, 6).Copy Sheets("المجموعة الثالثة").Range("A" & z).PasteSpecial xlPasteValues z = z + 1 End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End Sub employer.rar

أخى الفاضل / ريان أحمد تفضل ما تريد yy.rar

أخى الفاضل / عبد الله المجرب شكرا جزيلا أخى الفاضل على هذا المرور العطر وجزاك الله كل خير

بعد اذن أخى الحبيب / أبو حنين ولإثراء الموضوع هذا كود آخر Private Sub Worksheet_Selectionchange(ByVal Target As Range) x = Application.WorksheetFunction.Sum(Range("List")) ComboBox1.Clear If x = 0 Then ComboBox1.Visible = False Else ComboBox1.Visible = True For Each cl In Range("list") If cl > 0 Then ComboBox1.AddItem cl End If Next End If End Sub comboboxView.rar