ترحيل بيانات

[مجاهد2013]

السلام عليكم 

المطلوب في شيت pv عند كتابة اسم القسم و عدد التلاميذ يرحلهم مباشرة من شيت data إلى شيت Pv  حسب العدد المطلوب و يرحل الباقي حسب العدد المطلوب إلى المكان المطلوب 

و شكر ا  مسبقا 

 

med.xlsx

[سليم حاصبيا]

جرب هذا الكود

Option Explicit
Dim ARR()
Dim D As Worksheet, P As Worksheet, I#

Sub Data_VAL()
Dim K%: K = 1

Set D = Sheets("data"): Set P = Sheets("pv")
For I = 1 To D.Cells(Rows.Count, 1).End(3).Row
    If D.Range("A" & I).Interior.Color = RGB(220, 230, 241) Then
        ReDim Preserve ARR(1 To K)
        ARR(K) = D.Range("A" & I).Value
        K = K + 1
    End If
Next

    With P.Range("H5").Validation
     .Delete
     .Add 3, , , Join(ARR, ",")
    End With

End Sub
'++++++++++++++++++++++++++++++++++++++++++++
Sub get_data()
    Dim First_Ro%, Laste_ro%
    Dim Copy_RG As Range
    Dim clas
    Dim m%: m = 11
    Dim col: col = 2
Set D = Sheets("data"): Set P = Sheets("pv")
P.Range("A11:C500").ClearContents
P.Range("I11:K500").ClearContents
clas = P.Range("H5").Value
First_Ro = D.Range("A:D").Find(clas, after:=D.Cells(1000, 1), LOOKAT:=1).Row + 4
Laste_ro = D.Range("A" & First_Ro).End(4).Row
Set Copy_RG = D.Range(Cells(First_Ro, 2), Cells(Laste_ro, 3))
 For I = 1 To Copy_RG.Rows.Count
    If m = 36 Then m = 11: col = 10
        With P.Cells(m, col - 1)
            .Value = I
            .Offset(, 1) = Copy_RG.Cells(I, 1)
            .Offset(, 2) = Copy_RG.Cells(I, 2)
        End With
    m = m + 1
  Next
  
End Sub

الملف مرفق

med_SALIM.xlsm

[مجاهد2013]

أولا أستاذ سليم كيف أحوالك أتمنى تكون في تمام الصحة و العافية

المهم الكود شغال و لكن أنا أريد أن أرحل عدد معين من التلاميذ إلى الجدول و ليس العدد الكلي مثلا قسم 3أ ف به 45 تلميذا و أنا أريد أن أرحل 23 تلميذا يعني يرحل من 01 إلى 23 و لما أطلب أكتب القسم ثانية في الجدول الأخر يرحل من 24 إلى ......( حسب العدد المطلوب ) و هكذا

[سليم حاصبيا]

تعديل بسيط على الكود

وضع سطر اضافي بين علامات الـــ +++++

Option Explicit
Dim ARR()
Dim D As Worksheet, P As Worksheet, I#

Sub Data_VAL()
Dim K%: K = 1

Set D = Sheets("data"): Set P = Sheets("pv")
For I = 1 To D.Cells(Rows.Count, 1).End(3).Row
    If D.Range("A" & I).Interior.Color = RGB(220, 230, 241) Then
        ReDim Preserve ARR(1 To K)
        ARR(K) = D.Range("A" & I).Value
        K = K + 1
    End If
Next

    With P.Range("H5").Validation
     .Delete
     .Add 3, , , Join(ARR, ",")
    End With

End Sub
'++++++++++++++++++++++++++++++++++++++++++++
Sub get_data()
    Dim First_Ro%, Laste_ro%
    Dim Copy_RG As Range
    Dim clas
    Dim m%: m = 11
    Dim col: col = 2
Set D = Sheets("data"): Set P = Sheets("pv")
P.Range("A11:C500").ClearContents
P.Range("I11:K500").ClearContents
clas = P.Range("H5").Value
First_Ro = D.Range("A:D").Find(clas, after:=D.Cells(1000, 1), LOOKAT:=1).Row + 4
Laste_ro = D.Range("A" & First_Ro).End(4).Row
Set Copy_RG = D.Range(Cells(First_Ro, 2), Cells(Laste_ro, 3))
 For I = 1 To Copy_RG.Rows.Count
 '++++++++++++++++++++++++++++++
  If I > P.Range("H6") Then Exit Sub
 '+++++++++++++++++++++++++++++++
    If m = 36 Then m = 11: col = 10
        With P.Cells(m, col - 1)
            .Value = I
            .Offset(, 1) = Copy_RG.Cells(I, 1)
            .Offset(, 2) = Copy_RG.Cells(I, 2)
        End With
    m = m + 1
  Next
  
End Sub

الملف من جدبد

med_SALIM_new.xlsm

[مجاهد2013]

ألف شكر استاذنا تحياتي