اذهب الي المحتوي
أوفيسنا

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

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

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

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

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

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

  

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
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept