abuhanen10 قام بنشر أغسطس 6, 2017 مشاركة قام بنشر أغسطس 6, 2017 اخوانى الاعزاء عباقره اوفسينا هذا كود رائع للابجده بأنواعها حبيت اضيفه للشيت عندى يعطى كثير من الخطأ هل يمكن تطويعه ليعمل على اى شيت مع شرح الاسطر التى يجب تغييرها طبعا لن ارفع الكود فى ملف لانى اريد ان اضيفه بنفسى فى اكثر من شيت ولكم جزيل الشكر Sub ذكور_أولاً() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("J1").Value = "no" Then MsgBox "سجل النوع لكل الطلاب أولاً", , : Exit Sub If Range("L2").Value = 0 Then MsgBox "لا يوجد ذكور مُسجلون", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Set rngSort = Sheet2.Range("B3", Sheet2.Range("B3").SpecialCells(xlCellTypeLastCell)) rngSort.Select Selection.Sort Key1:=Sheet2.Range("B3"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Selection.Sort Key1:=Range("D3"), Order1:=xlDescending, Header:= _ xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الذكور أولاً" Application.ScreenUpdating = True End Sub Sub إناث_أولاً() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("J1").Value = "no" Then MsgBox "سجل النوع لكل الطلاب أولاً", , : Exit Sub If Range("M2").Value = 0 Then MsgBox "لا توجد إناث مُسجلات", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Set rngSort = Sheet2.Range("B3", Sheet2.Range("B3").SpecialCells(xlCellTypeLastCell)) rngSort.Select Selection.Sort Key1:=Sheet2.Range("B3"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Selection.Sort Key1:=Range("D3"), Order1:=xlAscending, Header:= _ xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الإناث أولاً" Application.ScreenUpdating = True End Sub Sub أبجدة_عامة() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Set rngSort = Sheet2.Range("B3", Sheet2.Range("B3").SpecialCells(xlCellTypeLastCell)) rngSort.Select Selection.Sort Key1:=Sheet2.Range("B3"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "أبجدة عامة" Application.ScreenUpdating = True End Sub Sub الأكبر() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("C1").Value = 0 Then MsgBox "لا توجد أرقام قومية مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Sheet2.Range("B3:E2003").Select Sheet2.Range("E3").Activate ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.Sort.SortFields.add Key:=Range("E1673"), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.Sort .SetRange Range("B3:E2003") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الأكبر أولاً" Application.ScreenUpdating = True End Sub Sub الأصغر() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("C1").Value = 0 Then MsgBox "لا توجد أرقام قومية مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Sheet2.Range("B3:E2003").Select Sheet2.Range("E3").Activate ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.Sort.SortFields.add Key:=Range("E1673"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.Sort .SetRange Range("B3:E2003") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الأصغر أولاً" Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر أغسطس 6, 2017 مشاركة قام بنشر أغسطس 6, 2017 أخي الكريم أبو حنين عفواً أنني أرى أنه ليس رائع كما تظن .. لو قمت بتسجيل ماكرو ستحصل على مثل هذه الأسطر الطويلة بلا فائدة وتأكيداً لكلامي اقرأ الحلقة التالية وستعرف مدى صدق كلامي وخاصة بالنسبة لموضوع الترتيب رابط هذا التعليق شارك More sharing options...
abuhanen10 قام بنشر أغسطس 8, 2017 الكاتب مشاركة قام بنشر أغسطس 8, 2017 استاذ ياسر اذا ممكن شرح هذا الكود فقط Sub الأكبر() If Range("A1").Value = 0 Then MsgBox "لا توجد أسماء مُسجلة", , : Exit Sub If Range("C1").Value = 0 Then MsgBox "لا توجد أرقام قومية مُسجلة", , : Exit Sub Application.ScreenUpdating = False sheet1.Range("B3:D2002").copy Sheet2.Visible = True Sheet2.Select Sheet2.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("R3:R2002").copy Sheet2.Select Sheet2.Range("E3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim cel As Range, rng As Range Dim rngSort As Range Set rng = Sheet2.Range("B3", Sheet2.Range("B2002").End(xlUp)) For Each cel In rng If cel.Value = "" Then cel.EntireRow.Hidden = True End If Next cel Sheet2.Range("B3:E2003").Select Sheet2.Range("E3").Activate ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.Sort.SortFields.add Key:=Range("E1673"), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.Sort .SetRange Range("B3:E2003") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rows("3:2002").EntireRow.Hidden = False Sheet3.Visible = True Sheet3.Range("B3:D2002").copy sheet1.Visible = True sheet1.Select sheet1.Range("B3").Select Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False sheet1.Range("B3").Select Call CleanB Sheet2.Visible = False Sheet3.Visible = False sheet1.Range("E1").Value = "الأكبر أولاً" Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان