كود رائع للاستاذ خالد الرشيدي .. مطلوب تطويع الكود للملف

[ناصر سعيد]

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

هذا كود للمحترم الاستاذ خالد الرشيدي ..

وهو اكثر من رائع

وقد حاولت اكثر من مره اضافته للملف المرفق ...

ولكن شاء الله ان استعين به اول

ثم بكم لكي يتوافق مع الملف

المطلوب

ان يتم ضبط الكود ليتوافق مع الملف

جزاكم الله خيرا

Sub كشوف_اللجان()
'*****************************************
'*****************************************
Dim Legan As Worksheet, Main As Worksheet
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long

Set Legan = Sheets("كشوف اللجان")
Set Main = Sheets("بيانات الطلبة")
'*****************************************

LR = Main.Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False

Sheets("كشوف اللجان").Unprotect Password:="1"

Legan.Range("C9:F39").ClearContents
Legan.Range("J9:M39").ClearContents

Arr = Main.Range("A9:W" & LR).Value
     Arr1 = Array(5, 15, 16)
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'==========
If Arr(i, 11) = Legan.Range("D4").Value Then
'*****************************************
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i

 Sheets("كشوف اللجان").Unprotect Password:="1", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
        ActiveSheet.EnableSelection = xlNoRestrictions
 Application.Visible = True
 Application.ScreenUpdating = True

End Sub

 

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

 

اللجان بطريقه استاذ خالد الرشيدي.rar

[ناصر سعيد]

للرفع

 

[ناصر سعيد]

تم الحل في هذا الرابط