مجاهد2013 قام بنشر نوفمبر 11, 2019 مشاركة قام بنشر نوفمبر 11, 2019 السلام عليكم المطلوب في شيت pv عند كتابة اسم القسم و عدد التلاميذ يرحلهم مباشرة من شيت data إلى شيت Pv حسب العدد المطلوب و يرحل الباقي حسب العدد المطلوب إلى المكان المطلوب و شكر ا مسبقا med.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر نوفمبر 11, 2019 مشاركة قام بنشر نوفمبر 11, 2019 جرب هذا الكود 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 1 رابط هذا التعليق شارك More sharing options...
مجاهد2013 قام بنشر نوفمبر 11, 2019 الكاتب مشاركة قام بنشر نوفمبر 11, 2019 أولا أستاذ سليم كيف أحوالك أتمنى تكون في تمام الصحة و العافية المهم الكود شغال و لكن أنا أريد أن أرحل عدد معين من التلاميذ إلى الجدول و ليس العدد الكلي مثلا قسم 3أ ف به 45 تلميذا و أنا أريد أن أرحل 23 تلميذا يعني يرحل من 01 إلى 23 و لما أطلب أكتب القسم ثانية في الجدول الأخر يرحل من 24 إلى ......( حسب العدد المطلوب ) و هكذا رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر نوفمبر 11, 2019 أفضل إجابة مشاركة قام بنشر نوفمبر 11, 2019 تعديل بسيط على الكود وضع سطر اضافي بين علامات الـــ +++++ 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 4 رابط هذا التعليق شارك More sharing options...
مجاهد2013 قام بنشر نوفمبر 11, 2019 الكاتب مشاركة قام بنشر نوفمبر 11, 2019 ألف شكر استاذنا تحياتي رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.