سليم حاصبيا

جرب هذا الملف Why_not.xlsx

هذا الكود يقوم بذلك Option Explicit Sub calcul() Dim lr% With Sheets("ورقة1") lr = Cells(Rows.Count, "E").End(3).Row .Range("H4:H" & lr).Formula = _ "=IF(AND(E4=$E$2,C4>=$C$2),30,E4)" .Range("H4:H" & lr).Copy .Range("E4").PasteSpecial (xlPasteValues) Application.CutCopyMode = False .Range("H4:H" & lr).Clear .Range("E4").Select End With End Sub

انسخ هذه المعادلة الى الخلية G4 واسحب نزولاً =IF(AND(E4=$E$2,C4>=$C$2),30,E4) اذا لم تعمل معك المعادلة استبدل الفاصلة بفاصلة منقوطة لتبدو هكذا =IF(AND(E4=$E$2;C4>=$C$2);30;E4)

جرب هذا الملف Updated data_val.xlsm

يمكنك استعما ل هذه المعادلة ( اشارة = في الاول و القوس في النهاية ) كل الحق على اللغة العربية =IF(COUNTIF($B$1:$B1,$B1)>1,"",$B1)

Option Explicit Sub Keep_the_first() With Sheets("ورقة1") Dim i, arr() Dim lr%: lr = .Cells(Rows.Count, 2).End(3).Row .Range("i1").Resize(lr).ClearContents ReDim arr(1 To lr) For i = 1 To lr If Application.CountIf(.Range("B1" & ":B" & i), .Range("B" & i)) = 1 Then '============================= arr(i) = .Range("B" & i) Else arr(i) = vbNullString End If Next .Range("I1").Resize(UBound(arr)) = _ Application.Transpose(arr) End With Erase arr End Sub الملف مرفق Hani.xlsm

تم التعديل على الماكرو ليتناسب مع المطلوب كل ما عليك هو اختيار اسم الاستاذ من الكومبو 1 او اسم المادة من الكومبو 2 Option Explicit Private Sub ComboBox1_Change() get_data_Prof End Sub '++++++++++++++++++++++++++++++++ Private Sub ComboBox2_Change() get_data_Matiere End Sub '+++++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() fil_combo End Sub '==================================== Sub fil_combo() Dim dic As Object, dic2 Dim cel As Range Set dic = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") '=========================== For Each cel In Sheets("جدول عام").Range("c66:c85") If Not dic.exists(cel.Value) And cel <> "" Then dic.Add cel.Value, "" dic2.Add cel.Offset(, -1).Value, "" End If Next '=========================== For Each cel In Sheets("جدول عام").Range("i66:i85") If Not dic.exists(cel.Value) And cel <> "" Then dic.Add cel.Value, "" dic2.Add cel.Offset(, -1).Value, "" End If Next ComboBox1.List = dic.keys ComboBox2.List = dic2.keys ComboBox1.BackColor = RGB(135, 255, 204) ComboBox2.BackColor = RGB(135, 255, 204) dic.RemoveAll: Set dic = Nothing dic2.RemoveAll: Set dic2 = Nothing End Sub '+++++++++++++++++++++++++++++++++++++++++++ Sub get_data_Prof() Dim Am As Worksheet: Set Am = Sheets("جدول عام") Dim Fr As Worksheet: Set Fr = Sheets("جدول فردي") Dim Rg_to_copy As Range Dim Start_Col%: Start_Col = 2 Dim Start_Row%: Start_Row = 9 Dim k%, x%, i% Fr.Range("B9:f12").ClearContents Fr.Range("B14:f17").ClearContents With Am .Range("c7:z14").Name = "Rg_1" .Range("c15:z22").Name = "Rg_2" .Range("c23:z30").Name = "Rg_3" .Range("c31:z38").Name = "Rg_4" .Range("c39:z46").Name = "Rg_5" End With For k = Start_Col To 6 Set Rg_to_copy = Am.Range("Rg_" & k - 1) For i = 1 To Rg_to_copy.Rows.Count On Error Resume Next x = Rg_to_copy.Rows(i).Find(Fr.Range("f6")).Column On Error GoTo 0 If x Then Cells(Start_Row, k) = Fr.Range("f6") End If Start_Row = Start_Row + 1 If Start_Row = 13 Then Start_Row = 14 x = 0 Next i Start_Row = 9 Next k End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub get_data_Matiere() Dim Am As Worksheet: Set Am = Sheets("جدول عام") Dim Fr As Worksheet: Set Fr = Sheets("جدول فردي") Dim Rg_to_copy As Range Dim Start_Col%: Start_Col = 2 Dim Start_Row%: Start_Row = 30 Dim k%, x%, i% Fr.Range("B30:f33").ClearContents Fr.Range("B35:f38").ClearContents With Am .Range("c7:z14").Name = "Rg_1" .Range("c15:z22").Name = "Rg_2" .Range("c23:z30").Name = "Rg_3" .Range("c31:z38").Name = "Rg_4" .Range("c39:z46").Name = "Rg_5" End With For k = Start_Col To 6 Set Rg_to_copy = Am.Range("Rg_" & k - 1) For i = 1 To Rg_to_copy.Rows.Count On Error Resume Next x = Rg_to_copy.Rows(i).Find(Fr.Range("F27")).Column On Error GoTo 0 If x Then Cells(Start_Row, k) = Fr.Range("B27") End If Start_Row = Start_Row + 1 If Start_Row = 34 Then Start_Row = 35 x = 0 Next i Start_Row = 33 Next k End Sub NEW_Repport.xlsm

جرب هذا الملف التسميات ( ..... RG_1,RG_2) تجدها داخل الملف Named Range الماكرو المستعمل Sub fil_table() Dim i%, t%, k% Dim MAIN_RG As Range Set MAIN_RG = Range("B9:F16") Dim VAR_RG As Range Set VAR_RG = Range("B7:F7") Dim RG_Saech As Range Dim My_MATCH As Range Dim COL% Range("B9:F16").ClearContents For k = 1 To 5 Select Case k Case 1 Set RG_Saech = Sheets("جدول عام").Range("RG_1") Case 2 Set RG_Saech = Sheets("جدول عام").Range("RG_2") Case 3 Set RG_Saech = Sheets("جدول عام").Range("RG_3") Case 4 Set RG_Saech = Sheets("جدول عام").Range("RG_4") Case 5 Set RG_Saech = Sheets("جدول عام").Range("RG_5") End Select For i = 9 To 16 t = i - 8 Set My_MATCH = RG_Saech.Rows(t) COL = Sheets("جدول عام").Range("b6:Z6").Find(Sheets("جدول فردي").Range("F6")).Column MAIN_RG.Cells(t, k) = Intersect(My_MATCH, Sheets("جدول عام").Cells(6, COL).Resize(62)) Next Next End Sub الملف مرفق OUSTAZ.xlsm

تم معالجة الامر (للمرة الثانية) 88888.xlsx

بدل المعادلة الثانية الى =REPLACE(A2,1,4,"")*1 Or =VALUE(REPLACE(A2,1,4,"")) واذا لم تعمل معك المعادلة استبدل الفاصلة بفاصلة منقوطة لتبدو المعادلة هكذا =REPLACE(A2;1;4;"")*1 Or =VALUE(REPLACE(A2;1;4;""))

الماكرو يجب وضعه في كود الصفحة التي تحتوي على cmdSearch وليس في Module مستقل

تم معالجة الامر بتصحيح التواريخ (عشوائية) Isdate_new.xlsx

يا صديقي ليس كل الأرقام في العامود C هي تواريخ (للتأكد هذا الملف) بانتظار تصحيحها لأعطاء المعادلات اللازمة Isdate.xlsx

تم التعديل على الماكرو Option Explicit Sub Salim_Code_new() Application.ScreenUpdating = False Const lngFirstRow = 7 Const lngRowsPerPage = 25 Dim my_ro#, x% Dim wshSource As Worksheet, wshTarget As Worksheet Dim rgSource As Range, rgTarget As Range Dim lngLastRow#, Final_row#, lngRow# Dim lngNumRows#, lngNumPages#, i# Dim My_arr(), k%: k = 8 + lngRowsPerPage My_arr = Array("Ok1", "", "Ok2", "", "Ok3", "", "Ok4", "", _ "Ok5", "", "Ok6") Set wshSource = Worksheets("الرئيسية") With wshSource lngLastRow = .Range("A:GC").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rgSource = .Range("FI" & lngFirstRow & ":GC" & lngLastRow) End With With Worksheets("الجديدة") .Cells.ClearContents Set rgTarget = .Range("A" & lngFirstRow) rgSource.Copy rgTarget.PasteSpecial xlPasteAll Final_row = .Cells(Rows.Count, 1).End(3).Row With .PageSetup .PrintArea = Range("a7:u" & Final_row).Address .Orientation = xlLandscape .PrintTitleRows = "$1:$7" End With End With Application.CutCopyMode = False lngNumRows = lngLastRow - lngFirstRow lngNumPages = lngNumRows \ lngRowsPerPage If lngNumRows Mod lngRowsPerPage > 0 Then lngNumPages = lngNumPages + 1 End If With Worksheets("الجديدة") .ResetAllPageBreaks For i = lngRowsPerPage + 8 To Final_row Step lngRowsPerPage .Range("A" & i).Resize(5).EntireRow.Insert .HPageBreaks.Add Before:=Range("A" & i + 5) .Range("b" & i + 1) = "SUM" If i = lngRowsPerPage + 8 Then .Range("d" & i + 1).Resize(, 18).Formula = _ "=SUM(D" & 8 & ":D" & 32 & ")" Else .Range("d" & i + 1).Resize(, 18).Formula = _ "=SUM(D" & k - 20 & ":D" & k - 1 & ")" End If .Range("a" & i + 2).Resize(, UBound(My_arr)) = My_arr k = k + 25 Next Final_row = .Cells(Rows.Count, 1).End(3).Row .Range("A" & Final_row + 1).Resize(5).EntireRow.Insert .PageSetup.PrintArea = Range("a7:u" & Final_row + 5).Address .Range("b" & Final_row + 2) = "SUM" .Range("a" & Final_row + 3).Resize(, UBound(My_arr)) = My_arr For i = Final_row To 2 Step -1 If .Range("B" & i) = vbNullString Then my_ro = .Range("B" & i).Row + 1 Exit For End If Next .Range("d" & Final_row + 2).Resize(, 18).Formula = _ "=SUM(D" & my_ro & ":D" & Final_row & ")" On Error Resume Next x = .VPageBreaks.Count If x <> 0 Then .VPageBreaks.DragOff Direction:=xlToRight, RegionIndex:=1 End If .UsedRange.Value = .UsedRange.Value .Range("a7").Select End With Application.ScreenUpdating = True End Sub الملف من جديد Example+SALIM.xlsm

الشارة % هي اختصار لعبارة As Integer واشارة # هي اختصار لعبارة As Double واشارة $ هي اختصار لعبارة As String وهناك الكثير

لا أعلم لما هذا التفصيل والاطالة في الكود واستعمال ثلاث متغيرات(R,M,O) (الجزء الاول من الكود) يمكن الاختصار هكذا (اذا كنت لا تريد ان يعمل علي اوتو _فلتر) Option Explicit Private Sub ComboBox1_Change() Dim R As Integer, M%: M = 5 Dim My_sh As Worksheet Application.ScreenUpdating = False Select Case Me.ComboBox1.Value Case "راسب": Set My_sh = Sheets("رسوب") Case "ناجح": Set My_sh = Sheets("ناجح") Case "دور ثانى": Set My_sh = Sheets("دور ثان فى") Case Else: GoTo End_Me End Select For R = 5 To 100 If Sheets("الشيت").Cells(R, 20) = Me.ComboBox1.Value Then Sheets("الشيت").Range("A" & R).Resize(1, 20).Copy My_sh.Range("A" & M).PasteSpecial xlPasteValues M = M + 1 End If Next End_Me: Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

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

جرب هذا الكود مع شرح لكل سطر من الكود باللغة الاجنبية Option Explicit Sub SheetsToWorkbooks() 'Step 1: Declare all the variables. Dim ws As Worksheet 'Step 2: Turn screen updating off to speed up your macro code Application.ScreenUpdating = False 'Step 3: Start the looping through sheets For Each ws In ThisWorkbook.Worksheets 'Step 4: Copy the target sheet to the new workbook ws.Copy 'Step 5: Save the new workbook with sheet name. ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ws.Name ActiveWorkbook.Close SaveChanges:=True 'Step 6: Loop back around to the next worksheet Next ws 'Step 7: Turn screen updating on Application.ScreenUpdating = True End Sub

كود رائع صديقي علي لكن يمكن اختصاره الى حد بعيد ليبدو هكذا بدون Private Sub Worksheet_SelectionChange Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) Dim my_sh my_sh = Target.Parent Sheets(my_sh).Visible = -1 Sheets(my_sh).Select End Sub '++++++++++++++++++++++++++ Private Sub Worksheet_Activate() On Error Resume Next Sheets(ActiveCell.Value2).Visible = False End Sub

بعد اذن اخي حسين زر واحد لتنفيذ الحالتين معاً وخاصية اظهار الشيت من خلال الـــ RIGHT CLICK على اسم الشيت غير مفعّلة حتى لا يستطيع المستخدم اظهار اي شيت بدون الكود الكود Option Explicit Private Sub ToggleButton1_Click() With ToggleButton1 If .Value = -1 Then SHOW_ALL .Caption = "HIDE ALL SHEETS" Else HIDE_ALL .Caption = "SHOW ALL SHEETS" End If End With End Sub '+++++++++++++++++++++++++++++++++++++++++++ Sub SHOW_ALL() Dim sh As Worksheet For Each sh In Sheets sh.Visible = -1 Next sh End Sub '+++++++++++++++++++++++++++++++++++++++ Sub HIDE_ALL() Dim t%: t = Sheets("الرئيسية").Index Dim x% For x = 1 To Sheets.Count If Sheets(x).Index <> t Then _ Sheets(x).Visible = 2 Next End Sub الملف للتجربة مرفق Show_hide_sheets.xlsm

على كل حال اذا كنت تريدها بواسطة الماكرو Option Explicit Sub sum_befor_date() Dim i%, x%, s#, My_date As Date Dim k%: k = 3 My_date = [CA1] Range("CA3", Range("CA2").End(4)).ClearContents x = Cells(1, Columns.Count).End(1).Column - 1 Do Until Cells(k, 3) = vbNullString For i = 3 To x Step 2 If CDate(Cells(3, i + 1)) > My_date Then Exit For s = s + Cells(3, i) Next Cells(k, "CA") = s: s = 0 k = k + 1 Loop End Sub

هذه الحكاية يلزمها ماكرو

هذه المعادلة من دون الــ Excel table الصفحة Salim من هذا الملف =SUMPRODUCT(--($C3:$BZ3<40000)*(($C3:$BZ3))) الرقم 40000 يقابل تاريخ 6/7/2009 ولا اعتقد ان هناك تاريخ في الجدول اقدم منه او اذا اردتها من خلال الــ Excel table =SUMPRODUCT(--(Table1[@[دفعه 1]:[تاريخ 38]]<40000)*(Table1[@[دفعه 1]:[تاريخ 38]])) الملف مرفق example.xlsx

جرب مبدئياً هذا الماكرو يمكن تحسينه فيما بعد ضع في My_arr داخل الكود ما تريد من تواقيع Option Explicit Sub Salim_Code() Const lngFirstRow = 7 Const lngRowsPerPage = 25 Dim my_ro# Dim wshSource As Worksheet, wshTarget As Worksheet Dim rgSource As Range, rgTarget As Range Dim lngLastRow#, Final_row#, lngRow# Dim lngNumRows#, lngNumPages#, i# Dim My_arr(), k%: k = 8 + lngRowsPerPage My_arr = Array("Ok1", "", "Ok2", "", "Ok3", "", "Ok4", "", _ "Ok5", "", "Ok6") Set wshSource = Worksheets("الرئيسية") With wshSource lngLastRow = .Range("A:GC").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rgSource = .Range("FI" & lngFirstRow & ":GC" & lngLastRow) End With With Worksheets("الجديدة") .Cells.ClearContents Set rgTarget = .Range("A" & lngFirstRow) rgSource.Copy rgTarget.PasteSpecial xlPasteAll Final_row = .Cells(Rows.Count, 1).End(3).Row With .PageSetup .PrintArea = Range("a7:u" & Final_row).Address .Orientation = xlLandscape .PrintTitleRows = "$1:$7" End With End With Application.CutCopyMode = False lngNumRows = lngLastRow - lngFirstRow lngNumPages = lngNumRows \ lngRowsPerPage If lngNumRows Mod lngRowsPerPage > 0 Then lngNumPages = lngNumPages + 1 End If With Worksheets("الجديدة") .ResetAllPageBreaks For i = lngRowsPerPage + 8 To Final_row Step lngRowsPerPage .Range("A" & i).Resize(5).EntireRow.Insert .HPageBreaks.Add Before:=Range("A" & i) .Range("b" & i + 1) = "SUM" If i = lngRowsPerPage + 8 Then .Range("d" & i + 1).Resize(, 18).Formula = _ "=SUM(D" & 8 & ":D" & 32 & ")" Else .Range("d" & i + 1).Resize(, 18).Formula = _ "=SUM(D" & k - 20 & ":D" & k - 1 & ")" End If .Range("a" & i + 2).Resize(, UBound(My_arr)) = My_arr k = k + 25 Next Final_row = .Cells(Rows.Count, 1).End(3).Row .Range("A" & Final_row + 1).Resize(5).EntireRow.Insert .PageSetup.PrintArea = Range("a7:u" & Final_row + 5).Address .Range("b" & Final_row + 1) = "SUM" .Range("a" & Final_row + 2).Resize(, UBound(My_arr)) = My_arr For i = Final_row To 2 Step -1 If .Range("B" & i) = vbNullString Then my_ro = .Range("B" & i).Row + 1 Exit For End If Next .Range("d" & Final_row + 1).Resize(, 18).Formula = _ "=SUM(D" & my_ro & ":D" & Final_row & ")" On Error Resume Next .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 .Range("a1").Select End With End Sub الملف مرفق Example_ٍsalim.xlsm

جرب هذا الماكرو Private Sub ComboBox1_Change() Application.EnableEvents = False On Error Resume Next ''''''''''''''''''''''''''''' Dim sheet_to As Worksheet Dim t$: t = ComboBox1.Value Dim My_name$ Dim My_rg As Range Select Case t Case "راسب": My_name = "رسوب" Case "ناجح": My_name = "ناجح" Case "دور ثانى": My_name = "دور ثان فى" End Select Set My_rg = Sheets("الشيت").Range("a4").CurrentRegion On Error Resume Next Sheets(My_name).Cells.Clear My_rg.AutoFilter 20, t My_rg.SpecialCells(12).Copy Sheets(My_name).Range("a4") If Sheets("الشيت").FilterMode Then Sheets("الشيت").ShowAllData: My_rg.AutoFilter End If Application.EnableEvents = True End Sub الملف مرفق Shool.xlsm