كود استدعاء بيانات بطريقه الفورمه للعلامه باقشير

[محمدي عبد السميع]

 

Sub Test_A()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 5, 6)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
 
End Sub

Sub Test_B()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 8, 9)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_C()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 11, 12)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'---------------------------------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'-----------------------------------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_D()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 14, 15)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'-----------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'-----------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_E()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 17, 18)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_F()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 20, 21)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_G()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 23, 24)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub Test_H()
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
Dim Ws As Worksheet, Sh 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 Ws = Sheets("المواد منفصله")
Set Sh = Sheets("data1")
LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Ws.Range("C5:H34").ClearContents
Arr = Sh.Range("A7:AB" & LR).Value
                                Arr1 = Array(2, 26, 27)
                               '========================
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)
'------------------------------------------
If Arr(i, 4) = Ws.Range("D3").Value Then
'------------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))

Next j
End If
Next i
If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
 Application.ScreenUpdating = True
End Sub
Sub SS_Show()
Subjects.Show
End Sub

 

استدعاء بيانات بطريقه الفورمه.xlsb

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

[حسونة حسين]

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

تم اختصار الاكواد الثمانيه الي كود واحد فقط

استدعاء بيانات بطريقه الفورمه.xlsb

[محمدي عبد السميع]

اضافه للنابغه الأستاذ حسونه حسن

يبارك له ربنا

اربط هذا الكود بزر الاستدعاء

Sub Test(Arr1 As Variant)
' ترحيل قائمة التلاميذ بناء على رقم الفصل
'-------------------------------------------------
    Dim Ws As Worksheet, Sh As Worksheet
    Dim Arr As Variant, Temp As Variant    ', Arr1 As Variant
    Dim LR As Long, i As Long, j As Long, p As Long
    '-----------------------------------------
    Set Ws = Sheets("المواد منفصله")
    Set Sh = Sheets("data1")
    LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row
    Ws.Range("C5:H34").ClearContents
    Arr = Sh.Range("A7:AB" & LR).Value
    ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
    For i = 1 To UBound(Arr)
        '------------------------------------------
        If Arr(i, 4) = Ws.Range("D3").Value Then
            '------------------------------------------
            p = p + 1
            For j = 0 To UBound(Arr1)
                Temp(p, j) = Arr(i, Arr1(j))

            Next j
        End If
    Next i
    If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp
    Application.ScreenUpdating = True
End Sub
Sub SS_Show()
Subjects.Show
End Sub

 

استدعاء بيانات بطريقه الفورمه 99(5).xlsb

[محمدي عبد السميع]

هل نتعشم من النابغه  الاستاذ حسونه

شرح اسطر الكود