[موضوع مميز]شرح عمل شيت كنترول ( درة أعمال العلامة عبد الله باقشير)[مثبت]

[ناصر سعيد]

استخراج شهادات الطلاب بمعيه رقم الجلوس .. فكره جديده

 

شهادات 2.rar

================

=MATCH($J4;INDEX(KH_RANG;0;2);0)

=INDEX(KH_RANG;$M4;3)

 

[ناصر سعيد]

الجديد اختلاف مكان صف بدايه صفحه المصدر وصف البدايه لصفحة الهدف

'Private Sub Worksheet_Activate()
Sub القــيم_الفريده()
'Private Sub Worksheet_Activate()

'هذاالكود خاص بالعلامه عبد الله باقشير
'حفظه الله
' الهدف من الكود هو الاتيان بالقيم الفريده
'تم هذا الكود في  23/06/2007
'' '' '' '' '' '' '' '''' '' '' '' '' '' '' ''
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

'مسح عمود القيم الفريده
[S9:S500].ClearContents

'متغير عمود القيم الفريده
Set MyRange = [S9:S500]

'اسم شيت المصدرورقم صف البدايه في شيت الهدف
For U = 9 To Sheets("بيانات الطلبة").[C1500].End(xlUp).Row

'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدروكذلك رقم الصف في شيت المصدر
   Cells(U, 19) = Sheets("بيانات الطلبة").Cells(U - 2, 22)
   
   'رقم عمودالبيانات الفريده في الشيت الهدف
If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 19)) > 1 Then

'رقم عمودالبيانات الفريده
  Cells(U, 19).ClearContents
End If
Next

'فرز عمود القيم الفريده
[S9:S500].Sort [S9], xlAscending

   Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

End Sub

https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=128040

[ناصر سعيد]

رائعة النابغه ياسر خليل في الترحيل بالمصفوفات
ترحيل أعمدة غير متجاورة لأعمدة غير متجاورة باستخدام المصفوفات

(كود حصري)
https://youtu.be/ndC28IqkkBw

** من يريد دعمي فليقم بالاشتراك في القناة وعمل لايك للفيديوهات

https://www.file-upload.com/ablfo2nqpekx

رابط الملف السابق

==============================================

الترحيل بشرط معين في عمود معين بسهوله ويسر بالمصفوفات

للنابغه ياسر خليل

Option Explicit
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو ترحيل بشرط
'تم هذا الكود في 15/2/2017
Sub UsingArrays()
    Dim arr     As Variant
    Dim temp    As Variant
    Dim lr      As Long
    Dim i       As Long
    Dim j       As Long
    Dim c       As Long
    
    'متغير اسم ورقة المصدر
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
        'متغير اسم ورقة المصدرومدى البيانات بها
    arr = Sheets("Sheet1").Range("A2:C" & lr).Value
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    j = 1
    
    For i = LBound(arr, 1) To UBound(arr, 1)
    
        ' المعيار او الشرط الذي نبحث به
        If arr(i, 3) Like "*" & "P" & "*" Then
       
            For c = LBound(arr, 2) To UBound(arr, 2)
                temp(j, c) = arr(i, c)
            Next c
            j = j + 1
        End If
    Next i
    
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم ترحيل العناوين اليها
   Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("Names", "Marks", "Status")
   
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها
    Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp
End Sub

ستدعاء بشرط.rar

ملف الكود السابق

[ناصر سعيد]

كود لوضع دوائر حسب

معطيات الغياب واقل من درجه معينه في اعمده معينه...

يحفظك ربنا ويرعاك الاستاذ زيزو العجوز

الكود التالى لمسح الدوائر

و استخدم زر " Button" بدلا من استخدام الشكل التلقائى

Sub Circles()
'هذا الكود للمحترم النابغه زيزو العجوز
'الهدف من الكود هو وضع دوائر على درجات  في اعمده معينه
'تم هذا الكود في 19/5/2017

'استدعاء كود المسح اولا
Call DeletingShp

'متغيرات
Dim ws As Worksheet
Dim Arr() As Variant
Dim LR As Long, R As Long, i As Long
Dim Cel As Range

'اسم صفحه العمل
Set ws = Sheets("شيت")

  ' هذا شرط الا يعمل الكود قبل الصف 14
If LR < 14 Then LR = 14

'متغير لعد الصفوف
LR = ws.Range("C" & Rows.Count).End(xlUp).Row

'ارقام الاعمده المطلوب وضع دوائر فيها
Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37)

'بدايه الصفوف
For R = 14 To LR

  ' عرض المصفوفة الخاصة بالاعمدة
For i = LBound(Arr) To UBound(Arr)

  ' نطاق تطبيق الامر وهو الخاص برسم الدوائر
For Each Cel In ws.Cells(R, Arr(i))

  '  الشرط الذى على اساسه سوف يتم رسم الدوائر
If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then

  ' مواصفات الشكل وهو هنا عبارة عن دائرة وما بين الاقواس هو ابعاد الدائرة حتى لا تصبح اكبر من حجم الخلية
Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height)

  ' مواصفات الدائرة من حيث درجة اللون وحجم الخط و الشفافية
xx.Fill.Visible = msoFalse
xx.Line.ForeColor.SchemeColor = 10
xx.Line.Weight = 1.2
  End If
 Next
  Next
   Next
End Sub

  '    الكود الثانى
Sub DeletingShp()

   ''  المتغيرات
    Dim shp As Shape, x As Long
    
     ' هذا النطاق يسمح بمسح كل الاشكال فى ورقة العمل سواء دائرة او غيرها
    For Each shp In ActiveSheet.Shapes
    
   '   امر المسح
      If shp.Type = 1 Then shp.Delete: x = x + 1
    Next shp
   '    رسالة بعدد الدوائر التى تم مسحها
'MsgBox "تم حذف   " & x & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub

=============

كود الدوائر وكود مسحها.

[ناصر سعيد]

'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'تم هذا الكود في 15/2/2017
    Sub استدعاء()
    Dim arr     As Variant
    Dim temp    As Variant
    Dim cr      As Variant
    Dim lr      As Long
    Dim i       As Long
    Dim j       As Long
    Dim c       As Long
    Dim ws As Worksheet
    Dim sh As Worksheet
    Set ws = Sheets("Sheet1")
    Set sh = Sheets("Sheet2")
    '= = = = = = = = = = = =
    ' شيت الهدف والمدى المطلوب مسحه
    sh.Range("B7:AJ10000").ClearContents
    
        ' اسم ورقة المصدر
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
            'متغير اسم ورقة المصدرومدى البيانات بها
    arr = ws.Range("A7:EF" & lr).Value
    
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
    'ارقام الاعمده المطلوب نقلها
    cr = Array(2, 3, 7, 8, 9, 11, 12, 24, 25, 35, 36, 46, 47, 57, 58, 72, 73)
    j = 1

    For i = LBound(arr, 1) To UBound(arr, 1)
    
   ' المعيار او الشرط الذي نبحث به ورقم عمود المعيار
        If arr(i, 135) Like "*" & "نا*" & "*" Then
            temp(j, 1) = j
            For c = LBound(cr) To UBound(cr)
                temp(j, c + 2) = arr(i, cr(c))
            Next c
            j = j + 1
        End If
    Next i
    
    ' اسم شيت الهدف
    With sh
    
        .Range("B7").Resize(j - 1, UBound(temp, 2)).Value = temp
        
        'سطر لمسح التسطير
        .Range("B7:AJ" & Rows.Count).Borders.Value = 0
        
        'سطر لاضافة التسطير
        .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1
    End With
End Sub

هذا الكود خاص باستدعاء اعمده معينه بناء على شرط ... ( النجاح )

 

استدعاء بشرط1.rar

[محمدأبوعبد الرحمن]

جزى الله جميع القائمين على هذا العمل العظيم خير الجزاء

[ناصر سعيد]

السلام عليكم
جديد..... جديد .... جديد ..... جديد

الجزء 51 نشرح ActiveSheet.UsedRange.Clear لمسح المحتويات مع التنسيقات وكذلك وضع بيانات في الاسطر الاربعه الأولى وكذلك استخدمنا with-endwith لعمل تنسيقات للنصوص

 

جزء51 توزيع الطلاب على اللجانwith endwith-usedrange.clearساجدة العزاوي

 

======

ملف الشرح السابق

توزيع-الطلاب-ج3.rar

[ناصر سعيد]

ملف رائع لتوزيع الطلاب على الفصول للنابغه ياسر خليل .. بارك الله فيه

 

 

================

 

تكوين فصول للمحترم ياســـــــــــــــــــر خليل.rar

[ناصر سعيد]

 

[ناصر سعيد]

 

[ناصر سعيد]

=========================

 

[محمد سامر]

بارك الله فيك أخي الفاضل

[ناصر سعيد]

 

    Sub SortData()
    Dim LR As Long
    LR = Range("B" & Rows.Count).End(xlUp).Row
    'مدى الفرز .. ثم معيار الفرز الاول
    'ثم معيار الفرز التاني
    Range("B9:K" & LR).Sort Key1:=Range("E9:E" & LR), Order1:=2, Key2:=Range("B9:B" & LR), Order2:=1, Header:=xlNo
    
End Sub

لفرز البنون والبنات ثم فرز البنون هجائيا وفرز البنات هجائيا

[ناصر سعيد]

المرفق النهائي الذي ينسخ الصفوف بالعدد في عده صفحات مختلفه

من ملف بسهوله ويسر وذلك

بعد مسح البيانات القديمه

وهو طبعا لخليفه العلامه عبد الله باقشير  المحترم ياسر العربي

وتعديل العبقري ياسر خليل وسبب التعديل ادخال جزئيه جديده لعمليه مسح البيانات القديمه

 

نسخ 1صفوف.rar

وهذا هو الكود المرفق بالملف لمن اراد الاستمتاع بالكنوز

 
 'هذا الكود للمحترم ياسر العربي
 ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب
 'وقبل النسخ يتم مسح البيانات القديمه
 'تاريخ الانشاء 30/7/2017
 'تم التعديل على الكود بواسطه المحترم ياسر خليل لوجود متطلبات جديده
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Private Sub CommandButton1_Click()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim c       As Long
    
    Set ws = Sheets("بيانات الطلبة")
    c = ws.Range("C2").Value
    
    If TextBox1.Text = ws.Range("F1") Then
        Me.Hide
        TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64
        
        Application.ScreenUpdating = False
        Application.Calculation = xlManual
        
 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل
            If ws.Range("C2") < 2 Then
                Exit Sub
            End If
            
            For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "رصد الترم الثانى", "كشف ناجح"))
                lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh))
                lc = LastOccupiedColNum(sh)
                
       'حذف البيانات الموجودة في النطاق المحدد
        sh.Range("A8").Resize(Rows.Count - 7, lc).Clear
                       
'نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين
    sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").Resize(c, lc)
            Next sh
            
            Application.Goto ws.Range("A1")
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
        Unload Me
    Else
        MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation
        TextBox1.Text = ""
        TextBox1.SetFocus
    End If
End Sub

Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedRowNum = lng
End Function

Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedColNum = lng
End Function
'==================================
Private Sub UserForm_Click()

End Sub

جزى الله كل من كان له بصمه في اخراج هذا العمل الى النور

[ناصر سعيد]

اكواد رائعه خاصه بعمل الكنترول في ملف

 

اكواد رائعه.rar

[ناصر سعيد]

ملف به كودين رائعين للمحترم الاستاذ ياسر خليل
حفظه الله ورعاه
كود لنسخ الصفوف بمسح البيانات القديمه
والكود الاخر بدون مسح البيانات القديمه لاضافه طالب محول بعد الطلاب
نسـخ صفوف في صفحات مختلفه 11.rar

 

 

==================================

Option Explicit
'هذا الكود للمحترم ياسر خليل
' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه
'يعمل الكود بدون مسح بيانات الطلاب القديمه
'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده
'تم هذا الكود في   25/8/2017

Sub CopyRow_Procedure()
    CopyRow "بيانات الطلبة", 9
    CopyRow "رصد الترم الثانى", 10
    CopyRow "كنترول شيت", 10
    CopyRow "الحاله", 11
    CopyRow "كشف ناجح", 9
    CopyRow "أعمال السنة", 7
    CopyRow "تحريرى ف 2", 7
    CopyRow "إنجاز1", 7
    CopyRow "تحريرى ف 1", 7
    CopyRow "كشف الدور الثاني", 9
    CopyRow "رصد الترم الأول", 10
    CopyRow "كنترول شيت (2)", 11

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    Application.Goto Sheets("بيانات الطلبة").Range("A1")
End Sub

Sub CopyRow(sSheet As String, sRow As Long)
    Dim ws      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim i       As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    On Error Resume Next
        Set ws = Sheets(sSheet)
        If ws Is Nothing Then
            MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!"
            Exit Sub
        End If
    On Error GoTo 0

    i = Sheets("بيانات الطلبة").Range("Q1").Value - 1
    lc = LastRowColumn(ws, "C")
    lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

    On Error GoTo Skipper
    ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy
    ws.Range("A" & lr).Resize(i + 1).PasteSpecial xlPasteAll
    ws.Range("A" & lr).Resize(i + 1, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents
Skipper:
    Application.Goto ws.Range("A1")
End Sub

Function LastRowColumn(ws As Worksheet, rc As String) As Long
    Dim lng     As Long

    If Application.WorksheetFunction.CountA(ws.Cells) <> 0 Then
        With ws
            If UCase(rc) = "R" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
            ElseIf UCase(rc) = "C" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
            End If
        End With
    Else
        lng = 1
    End If

    LastRowColumn = lng
End Function

 

الملف به الكودين .. دعاء لله ان يرحمنا جميعا ويرحم الاموات

نسـخ صفوف في صفحات مختلفه 11.rar

 

•  

[ناصر سعيد]

استاذ ياسر خليل
السلام عليكم ورحمة الله وبركاته
جزاك الله خيرا وبارك فيك .. آمين يارب العالمين
وبعد :

Sub القيم_الفريده()
'هذا الكود تم بواسطه المحترم ياسر خليل
'الهدف من الكود
'الاتيان بالقيم الفريده لبيانات في عمود
'تم في 31/8/2017
    Dim rng     As Range
    Dim a       As Variant
    Dim ws      As Worksheet
    
    'اسم الخليه في صفحه الهدف
    ' التي ستظهر بها القيم القريده
  Const strTRng  As String = "D4"
 
    'في صفحه الهدف العمود المطلوب
  ' وضع القيم الفريده فيه
    Const strHRng As String = "D4:D1000"
 
  'في صفحه المصدر العمود المطلوب
  ' استخراج القيم الفريده منه
    Const strSRng  As String = "C10:C200"
    
        'اسم الشيت في صفحه المصدر
    Const str   As String = "Sheet1"
      
    Set ws = Sheets(str)
'======================
    'نفترض وجود بيانات كأسماء في النطاق المذكور
    Set rng = ws.Range(strSRng)
   ActiveSheet.Range(strHRng).ClearContents
   
    'تخزين النتائج في مصفوفة
    a = GetDistinct(rng)
    
    'النطاق المطلوب وضع النتائج للأسماء الغير مكررة فيه
    ActiveSheet.Range(strTRng).Resize(UBound(a, 1) + 1) = Application.Transpose(a)
    
'فرز العمود المنقول اليه القيم الفريده
  [D4:D200].Sort [D4], xlAscending
 
  'عمود القيم الفريده ستتم عليه بعض التنسيقات
   With ActiveSheet.Range(strHRng)
   
   'تنسيق العمود تكست
.EntireColumn.NumberFormat = "@"
.Font.Bold = True
.ReadingOrder = xlRTL: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter

End With
    
End Sub

Function GetDistinct(ByVal oTarget As Range) As Variant
    Dim dic         As Object
    Dim vArr        As Variant
    Dim v           As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    vArr = oTarget

    For Each v In vArr
        If Not IsEmpty(v) Then dic(v) = v
    Next v

    GetDistinct = dic.Items()
End Function

 

================

منقول للافاده من

http://excel-egy.com/forum/t68&count=12

[ابن بنها]

 

[ناصر سعيد]

ملف التطبيق

http://www.mediafire.com/file/yr1rrb7...

==============================

http://gulfup.co/itpyj0db0zzp

================================

رابط اخر

https://up.top4top.net/downloadf-644qz4ck1-rar.html

 

=================

Sub sajida()
'===================
'هذا الكود للنابغه ساجدة العزاوي
'الهدف من الكود هو استخراج وطباعه شهادات الناجحين
'كل 4 شهادات في صفحه واحده
'تم هذا الكود في 6/10/2017
'=*=*=*=*=*=*=*
 Dim SHehada As Worksheet, DATA As Worksheet, Z As Range
    Set DATA = Worksheets("رصد الترم الثانى")    'اسم شيت قاعدة البيانات
    Set SHehada = Worksheets("4شهادات")    'اسم الشيت الخاص بالشهادات
    Dim myArray, targt
    targt = "ناج*"    'خلية البحث
   Set Z = SHehada.Range("M3")
'===================
c = 0
Application.ScreenUpdating = False
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row   'اخر صف به بيانات

' عدد الصفوف الخارجة عن التوزيع في ورقة مصدر البيانات
    For i = 7 To lr
    '=======
     If DATA.Cells(i, 101) Like targt & "*" And c = 0 Then

          '  If (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 0 Then
     Z = DATA.Cells(i, 2)
            c = c + 1
            '===
           ' ElseIf (DATA.Cells(i, 101) Like "*" & "ناج" & "*" And c = 1 Then
   ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 1 Then
     SHehada.Range("M19") = DATA.Cells(i, 2)
            c = c + 1
           ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 2 Then
   ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 2 Then

     SHehada.Range("M35") = DATA.Cells(i, 2)
            c = c + 1
           ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 3 Then
   ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 3 Then

     SHehada.Range("M51") = DATA.Cells(i, 2)
            c = c + 1
            End If
            
    If i = lr And c = 4 Then SHehada.Range("a1:p63").PrintOut: Exit For
    If i = lr And c = 3 Then SHehada.Range("a1:p47").PrintOut: Exit For
    If i = lr And c = 2 Then SHehada.Range("a1:p31").PrintOut: Exit For
    If i = lr And c = 1 Then SHehada.Range("a1:p15").PrintOut: Exit For
    If i < lr And (SHehada.Range("M19") = "" Or SHehada.Range("M35") = "" Or SHehada.Range("M51") = "") Then GoTo 1
    If i < lr And c = 4 Then SHehada.Range("a1:p63").PrintOut
      c = 0
     Z = ""
     SHehada.Range("M19") = ""
     SHehada.Range("M35") = ""
     SHehada.Range("M51") = ""
    
1:
   Next i
     Z = ""
     SHehada.Range("M19") = ""
     SHehada.Range("M35") = ""
     SHehada.Range("M51") = ""
   Application.ScreenUpdating = True
End Sub

'=*=*=**=*=*=*=*=*

 

[ناصر سعيد]

'تسطير الصفوف المحتوية على البيانات
x = Range(Range("A1").CurrentRegion.Address).Rows.Count
With Range("A3:L" & x)
    .Borders.LineStyle = 1
End With

جمل برمجيه مفيده

[ابن بنها]

كود رائع لازاله المسافات بين الكلمات

يصلح مع كود الفرز

Sub kh_TrimSelection()
On Error Resume Next
Dim cel As Range
For Each cel In Selection.Cells
    If Not IsNumeric(cel) Then
        cel.Value = WorksheetFunction.Trim(cel)
    End If
Next
On Error GoTo 0
End Sub

قف على اي خليه في عمود وسيتم بعد الضغط على الزر من ازاله المسافات بين الكلمات في العمود

[صـدّيـق]

[ناصر سعيد]

عمل اللجان المدرسيه الخاصه بالكنترول المدرسي بالمصفوفات

لجان كنترول مدرسي.rar

 

Sub Legan_Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim arr         As Variant
    Dim arrC        As Variant
    Dim temp1       As Variant
    Dim temp2       As Variant
    Dim lr          As Long
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim p1          As Long
    Dim p2          As Long

    Set ws = Sheets("بيانات الطلبة")
    Set sh = Sheets("كشوف المناداة")

    lr = ws.Cells(Rows.Count, 5).End(xlUp).Row
    
    Application.ScreenUpdating = False
        sh.Range("C10:F39").ClearContents
        sh.Range("K10:N39").ClearContents
        sh.Rows("10:39").Hidden = False
        
        arr = ws.Range("A7:V" & lr).Value
        arrC = Array(2, 5, 15, 16)
        ReDim temp1(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        ReDim temp2(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        
        For i = 1 To UBound(arr)
            If arr(i, 18) = sh.Range("E3").Value Then
                p1 = p1 + 1
                For j = 0 To UBound(arrC)
                    temp1(p1, j) = arr(i, arrC(j))
                Next j
            End If
            If arr(i, 18) = sh.Range("M3").Value Then
                p2 = p2 + 1
                For j = 0 To UBound(arrC)
                    temp2(p2, j) = arr(i, arrC(j))
                Next j
            End If
        Next i
    
        If p1 > 0 Then sh.Range("C10").Resize(p1, UBound(temp1, 2)).Value = temp1
        If p2 > 0 Then sh.Range("K10").Resize(p2, UBound(temp2, 2)).Value = temp2
        
        If p1 > 0 Then k = p1
        If p2 > 0 And p2 > k Then k = p2
        k = k + 10
        If k < 39 Then sh.Rows(k & ":39").Hidden = True
        
        Application.Visible = True
    Application.ScreenUpdating = True
End Sub

 

[ناصر سعيد]

 

[ناصر سعيد]