اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

محمدي عبد السميع
 مشاركة

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

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

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

قام بنشر
قام بنشر

  

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

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

  • Like 1
رابط هذا التعليق
شارك
حسونة حسين

حسونة حسين

قام بنشر
قام بنشر

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

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

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

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك
محمدي عبد السميع

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

قام بنشر
  • الكاتب
قام بنشر

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

يبارك له ربنا

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

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

  • Like 2
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept