ابراهيم الحداد

اخى الكريم الاستاذ ناصر السلام عليكم ورحمة الله اليك شرح الكود كما طلبت عسى الله ان اكون قد وفقت وفقنا الله واياكم لما يحب ويرضى Sub LClasses() الاعلان عن المتغيرات ' Dim ws As Worksheet, sh As Worksheet Dim Arr As Variant, Temp As Variant, Temp2 As Variant Dim LR As Long, i As Long, j As Long, f As Long, p As Long, q As Long Dim x, y, a, b, c, d, xx, yy Dim c1, c2, c3, c4 Dim d1, d2, d3, d4 Set ws = ThisWorkbook.Sheets("بيانات الطلبة") تعريف الشيت الاول وهو مصدر البيانت' Set sh = ThisWorkbook.Sheets("كشوف المناداة") تعريف الشيت الثانى قوائم اللجان' LR = ws.Range("E" & Rows.Count).End(xlUp).Row + 6 آخر صف فى الشيت الاول' Arr = ws.Range("A7:P" & LR).Value تحديد نطاق المصفوفة المصدر' ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) اعادة تعين المصفوفة الثانية الخاصة بكشف اللجان الاول' ReDim Temp2(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) عادة تعين المصفوفة الثانية الخاصة بكشف اللجان الثانى' sh.Range("B9:N34").ClearContents مسح اللجان قبل تفريغ اى بيانات جديدة' a = sh.Range("D7").Value رقم اللجنة الاولى' b = sh.Range("L7").Value رقم اللجنة الثانية ' On Error Resume Next c = WorksheetFunction.VLookup(a, sh.Range("AE3:AF" & sh.Range("AF" & Rows.Count).End(xlUp).Row), 2, 0) التأكد من عدد اللجان للقائمة الاولى' d = WorksheetFunction.VLookup(b, sh.Range("AE3:AF" & sh.Range("AF" & Rows.Count).End(xlUp).Row), 2, 0) التأكد من عدد اللجان للقائمة االثانية'' x = (a - 1) * c + 1: xx = a * c التعرف على اول و آخر طالب فى الكشف الاول' y = (b - 1) * d + 1: yy = b * d التعرف على اول و آخر طالب فى الكشف االثانى' 0 For i = 1 To UBound(Arr, 1) تنبيه الكود بالصفوف التى سوف يتم العمل عليها فى المصفوفة الام' If i >= x And i <= xx Then شرط الصفوف المطلوبة من المصفوفة الام لكل لجنة ' p = p + 1 العد حسب الشرط الموضح بعاليه' For j = 1 To 4 عدد الاعمدة المطلوبة من المصفوفة الام للمصفوفة الجديدة والتى تخص اللجنة الاولى ( التى هى على يمين الورقة )' Temp(p, j) = Arr(i, Choose(j, 2, 5, 15, 16)) تحديد المصفوفة الجديد او المطلوبة واختيار اعمد بعينها ' sh.Cells(p + 8, 2) = p ترقيم الطلاب فى اللجنة ' Next End If If i >= y And i <= yy Then الشرط الثانى وهو الذى يخص اللجنة الثانية - باقى الشرح نفس الشرح السابق' q = q + 1 For f = 1 To 4 ' Temp2(q, f) = Arr(i, Choose(f, 2, 5, 15, 16)) Cells(q + 8, 10) = q ' Next End If Next If p > 0 Then sh.Range("C9").Resize(p, j).Value = Temp اتصدير المصفوفة الجديدة الاولى كما رتب لها' If q > 0 Then sh.Range("K9").Resize(q, f).Value = Temp2 اتصدير المصفوفة الجديدة الثانية كما رتب لها' الخطوات بالاسفل اعتقد انها واضحة تماما وهى احصيات ''' c1 = WorksheetFunction.CountIf(sh.Range("E9:E34"), "*" & "مسلم" & "*") c2 = WorksheetFunction.CountIf(sh.Range("E9:E34"), "*" & "مسيحى" & "*") c3 = WorksheetFunction.CountIf(sh.Range("F9:F34"), "*" & "منقول" & "*") c4 = WorksheetFunction.CountIf(sh.Range("F9:F34"), "*" & "باق" & "*") d1 = WorksheetFunction.CountIf(sh.Range("M9:M34"), "*" & "مسلم" & "*") d2 = WorksheetFunction.CountIf(sh.Range("M9:M34"), "*" & "مسيحى" & "*") d3 = WorksheetFunction.CountIf(sh.Range("N9:N34"), "*" & "منقول" & "*") d4 = WorksheetFunction.CountIf(sh.Range("N9:N34"), "*" & "باق" & "*") خلايا نتائج الاحصائيات''' sh.Range("F3") = c sh.Range("F6") = c1 sh.Range("F7") = c2 sh.Range("F4") = c3 sh.Range("F5") = c4 sh.Range("N3") = d sh.Range("N6") = d1 sh.Range("N7") = d2 sh.Range("N4") = d3 sh.Range("N5") = d4 End Sub

السلام عليكم ورحمة الله استبدل هذا السطر If ws.Cells(LS, "BH") = sm.OLEObjects("Combobox1").Object.Value Then بهذا السطر If ws.Cells(LS, "BH") = sm.OLEObjects("Combobox1").Object.Value And ws.Range("BI" & LS) = sm.OLEObjects("Combobox2").Object.Value Then واستبدل هذا السطر If c <> 1 And ws.Range("BH" & LS) <> "" Then بهذا السطر If c <> 1 And ws.Range("BH" & LS) <> "" And ws.Range("BI" & LS) = sm.OLEObjects("Combobox2").Object.Value Then

السلام عليكم ورحمة الله بفرض انك خصصت الخلية "F3" لرقم الفاتورة يمكنك تغيير مكان الخلية كما تشاء انسخ هذا الكود والصقه فى حدث "ThisWorkBook" Private Sub Workbook_Open() Dim InvName As String InvName = Left(ActiveWorkbook.Name, 3) Sheet1.Range("F3") = InvName End Sub

السلام عليكم ورحمة الله اخى الكريم لا شكر على واجب والله فى عون العبد ما دام العبد عون اخيه تفضل تم اصلاح المطلوب البيانات.rar

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

اخى الكريم الاستاذ ناصر السلام عليكم ورحمة الله تم زيادة نطاق اللجنة حتى 26 طالب يجب تعبئة جدول توزيع الطلاب على اللجان يتم اختيار رقم اللجنة من القائمة المنسدلة فى الخلية "D4" فتتغير تلقائيا اللجنة المجاورة ختى نفاذ عدد اللجان الموزعة اليك الملف بعد التعديل تقبل فائق تحياتى قوائم اللجان.rar

السلام عليكم ورحمة الله اخى الكريم انظر الى هذا الملف قوائم اللجان.rar

السلام عليكم ورحمة الله استبدل هذا السطر : If c > 1 And ws.Range("BH" & LS) <> "" Then بهذا السطر : If c > 1 And ws.Range("BH" & LS) <> "" And ws.Range("BI" & LS) = sm.Range("F1") Then

السلام عليكم ورحمة الله اتمنى ان يكون هذا الكود هو ما تصبو اليه ملحوظة هامة : عند كتابة الاشهر التى تبدأ بحرف " أ " تأكد من الهمزة على حرف الألف Sub ADDToArchive() Dim ws As Worksheet, sh As Worksheet, sm As Worksheet Dim LR As Long, LS As Long, S As Long, x As Integer, cel As Range Dim a As Integer, b As Integer, c As Integer Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False If sm.Range("E1") = "" Or sm.Range("F1") = "" Then MsgBox "من فضلك اكمل التاريخ اولا" Exit Sub End If LS = ws.Range("A" & Rows.Count).End(xlUp).Row If ws.Cells(LS, "BH") = sm.Range("E1") Then MsgBox " هذا الشهر سبق ادراجه بالفعل " Exit Sub End If a = Month(DateValue("01 " & sm.Range("E1").Value)) If ws.Range("BH" & LS) = "" Then b = 0 Else b = Month(DateValue("01 " & ws.Range("BH" & LS).Value)) End If c = a - b If c > 1 And ws.Range("BH" & LS) <> "" Then MsgBox " تأكد من اسم الشهر مرة اخرى يوجد شهر او اكثر غير مدرج" Exit Sub End If For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then x = WorksheetFunction.Count(sh.Range("C6:C32")) sh.Range("C6:BI32").Copy LR = ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A" & LR + 1).PasteSpecial xlPasteValues ws.Range("BH" & LR).Resize(x + 1) = sm.Range("E1") ws.Range("BI" & LR).Resize(x + 1) = sm.Range("F1") Application.CutCopyMode = False End If Next End Sub

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Sub ADDToArchive() Dim ws As Worksheet, sh As Worksheet, sm As Worksheet Dim LR As Long, x As Integer, cel As Range Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then x = WorksheetFunction.Count(sh.Range("C6:C32")) sh.Range("C6:BI32").Copy LR = ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A" & LR + 1).PasteSpecial xlPasteValues ws.Range("BH" & LR + 1).Resize(x + 1) = sm.Range("E1") ws.Range("BI" & LR + 1).Resize(x + 1) = sm.Range("F1") ws.Range("A6").Select Application.CutCopyMode = False End If Next End Sub

استاذنا الكبير و المبدع / محمد صالح عودتك الى المنتى بعد غيبة ليست بالقصيرة اعادت اليه الحياة لا حرمنا الله من ابداعاتك جعله الله تبارك وتعالى فى ميزان حسناتك باذن الله

السلام عليكم ورحمة الله انسخ هذا الكود وكرره بعدد الازرار المطلوب الترقيم بها و لا تنسى تغيير اسم الخلية "J4" الى اسم الخلية المطلوبة وتغيير اسم الكود باضافة رقم مثلا الى اسم الكود فى كل مرة تلصق فيها الكود Sub CounNum() Dim x As Long x = Sheet1.Range("J4").Value x = x + 1 Sheet1.Range("J4").Value = x End Sub Sub RoundDiagonalCornerRectangle87_Click() Call CounNum End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول وخصص له زر Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then sh.Range("C6:BI32").Copy With ws LR = ws.Range("A" & Rows.Count).End(xlUp).Row If LR < 5 Then LR = 5 End If ws.Range("A" & LR + 1).PasteSpecial xlPasteValues For Each cel In ws.Range("BH6:BH" & Range("A" & Rows.Count).End(xlUp).Row) cel.Value = sm.Range("E1") cel.Offset(0, 1) = sm.Range("F1") .Range("A6").Select Next End With End If Next Application.CutCopyMode = True End Sub

السلام عليكم ورحمة الله استاذى الكبير محمد حسن هذه لمسات فنان مبدع ومبهر بارك الله فيك لا تحرمنا من جديدك

السلام عليكم ورحمة الله تفضل ayman.rar

السلام عليكم ورحمة الله انسخ الكود التالى وضعه فى حدث شيت العملاء Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column <> 2 Then Exit Sub Dim sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If Target.Value = sh.Name Then sh.Activate End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول وخصص له زر Sub HidRang() Dim rng As Range, cel As Range Dim LR As Long, x As Long, y As Long LR = Sheets("كروت عملاء").Range("B" & Rows.Count).End(xlUp).row Application.ScreenUpdating = False Set rng = Sheets("كروت عملاء").Range("B5:B" & LR) rng.Rows.EntireRow.Hidden = False For Each cel In rng If cel.Value = Sheets("كروت عملاء").Range("B2") Then x = cel.row y = x - 3 Rows("3:" & y).EntireRow.Hidden = True End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اليك الملف بعد التنقيح نماذج.rar

السلام عليكم ورحمة الله الكود يعمل فى منتهى الكفاءة لدى يبدو ان المشكلة عندك و لا ادرى ماهى على كل حال ضع هذه المعادلة فى الخلية "F4" ثم اسحب نزولا الى اخر خلية =SUMPRODUCT(--(D4=$D$4:$D$16);--(C4<$C$4:$C$16))+1

السلام عليكم ورحمة الله تفضل اخى الكريم élève.rar

السلام عليكم ورحمة الله اكتب هذه المعادلة فى الخلية التى تريد ثم اسحب نزولا =COUNTA(G6:M6)

اخى الكريم السلام عليكم ورحمة الله كان هناك خلل بسيط فى الخلايا التى يوجد بها الهايبر لنك فى الورقلة1 فتم نسخ الهايبر من ورقة اخرى بدلا منها اليك الملف بعد التعديل نماذج.rar

السلام عليكم ورحمة الله ضع هذا الكود فى موديول وخصص له زر فى اى ورقة تريد البحث فيها Sub SelFomula() Dim cel As Range For Each cel In ActiveSheet.UsedRange If cel.HasFormula Then MsgBox cel.Address End If Next End Sub

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الورقة "ThisWorkBook" واترك الكودين السابقين كما هما Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Target.Column = 1 Then Call VisiblHide End If End Sub

السلام عليكم ورحمة الله ضع الكود الاول فى حدث الورقة 1 اما الكودين التاليين فضعهما فى موديول Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 Then Call VisiblHide End If End Sub Sub UnhideAll() Dim j As Long For j = 2 To Sheets.Count If Sheets(j).Name <> "ورقة1" Then Sheets(j).Visible = False End If Next End Sub Sub VisiblHide() Dim cel As Range Call UnhideAll For Each cel In Sheet1.Range("A1:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row) If ActiveCell.Value = Sheets(cel.Value).Name Then Sheets(cel.Value).Visible = True End If Next End Sub