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

abuhanen10 · أغسطس 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

ياسر خليل أبو البراء · أغسطس 6, 2017

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

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

abuhanen10 · أغسطس 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

تسجيل الدخول

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

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

abuhanen10

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

abuhanen10

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information