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

اخى الكريم الاستاذ ناصر السلام عليكم ورحمة الله تم زيادة نطاق اللجنة حتى 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

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الصفحة Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False Dim dat As Byte dat = Month(Now) If dat = 1 Then Columns("DI:DE").Hidden = False Else Columns("DI:DE").Hidden = True End If If dat = 6 Then Columns("DK").Hidden = False Else Columns("DK").Hidden = True End If If dat = 7 Then Columns("DK").Hidden = False Else Columns("DK").Hidden = True End If Application.ScreenUpdating = True End Sub

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

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى الموديول Sub HidUnhde() Dim dat As Byte dat = Month(Now) If dat = 1 Then Columns("DI:DE").Hidden = False End If If dat = 6 Then Columns("DK").Hidden = False End If If dat = 7 Then Columns("DK").Hidden = False End If End Sub

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

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