كود فرز النوع

[2saad]

اخواني الأعزاء تحية طيبة وبعد

محتاج كود لترتيب الذكور أولا وبعدها الإناث 

وكود يرحل الذكور في ورقة عمل والإناث في ورقة أخري

الملف المرفقتقرير صف أول 2025.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

Option Compare Text
Public Property Get F() As Worksheet: Set F = Worksheets("Sheet1")
End Property

Sub Sort_Category()
Dim OneRng As Range
Dim lr As Long
lr = F.Cells(Rows.Count, "E").End(xlUp).Row
  Set OneRng = F.Range("A2:L" & lr)
  With OneRng
  .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo
  End With
End Sub
'*****************************
Sub Filter_and_create_Sheets()
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  F.[w1] = F.[E1]
  RngA = F.[A1].CurrentRegion.Rows.Count
  RngB = F.[A1].CurrentRegion.Columns.Count
  F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy, _
                        CopyToRange:=F.[w1], Unique:=True
  For Each c In F.Range("W2:W" & F.[W65000].End(xlUp).Row)
  F.[W2] = c.Value
     On Error Resume Next
     Sheets(CStr(c.Value)).Delete
     On Error GoTo 0
     Sheets.Add After:=Sheets(Sheets.Count)
     Set n = ActiveSheet
     n.Name = CStr(c.Value)
     n.DisplayRightToLeft = True
     F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy _
                 , CriteriaRange:=F.[W1:W2], CopyToRange:=[A1]
    For r = 1 To 12
    n.Cells.EntireRow.AutoFit
    n.Columns(r).ColumnWidth = F.Columns(r).ColumnWidth
     Application.ErrorCheckingOptions.NumberAsText = False
    Next
   Next c
    F.Activate
End Sub

 

تقرير صف أول 2025.xlsm

تم تعديل يوليو 5, 2024 بواسطه محمد هشام.

[2saad]

بارك الله فيك أخي الاستاذ محمد وزادك الله من علمه