اذهب الي المحتوي
أوفيسنا

ممكن تطويع هذا الكود ليعمل مع اى شيت

abuhanen10

بواسطه abuhanen10
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

abuhanen10

abuhanen10

قام بنشر
قام بنشر

اخوانى الاعزاء 

عباقره اوفسينا

هذا كود رائع للابجده بأنواعها حبيت اضيفه للشيت عندى يعطى كثير من الخطأ

هل يمكن تطويعه ليعمل على اى شيت مع شرح الاسطر التى يجب تغييرها

طبعا لن ارفع الكود فى ملف لانى اريد ان اضيفه بنفسى فى اكثر من شيت

ولكم جزيل الشكر 

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

 

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي الكريم أبو حنين

عفواً أنني أرى أنه ليس رائع كما تظن .. لو قمت بتسجيل ماكرو ستحصل على مثل هذه الأسطر الطويلة بلا فائدة وتأكيداً لكلامي اقرأ الحلقة التالية وستعرف مدى صدق كلامي وخاصة بالنسبة لموضوع الترتيب

 

رابط هذا التعليق
شارك
abuhanen10

abuhanen10

قام بنشر
  • الكاتب
قام بنشر

استاذ ياسر

اذا ممكن شرح هذا الكود فقط 

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

 

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept