اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

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

 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept