حل مشكلة عدم ترحيل كل الصفوف التي تحقق الشرط

[فارس حسن]

السلام عليكم 

طبعا هذه اول مشاركة لي بهذا الموقع المتميز

ارجو من الاخوة الافاضل ايجاد حل للمشكلة بالكود 

فالمطلوب نسخ الصفوف التي تحقق شرط في 3  شيتات وتجميع في البيانات المنسوخة بشيت اخر

لكن الذي يحدث ان الكود ياخذ اول صف يحقق الشرط فقط ... ويهمل بقية الصفوف التي تحقق الشرط

وملف العمل مرفق

واعتذر اذا كان مكان النشر غير صحيح

نسخ الطلبة المنقولين.xlsm

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

اظن انه ليس هناك حاجة لاستعمال البوزرفورم (فقط اضغط الزر GO في الصفحة  Target )

الكود

Option Explicit

Sub AL_in_One()
  Dim T As Worksheet
  Dim Sh As Worksheet
  Dim arr(), itm
  Dim Max_ro%, k%
  Dim Adr1%, Adr2%
  Dim F_rg As Range
 
 arr = Array("First", "Second", "Third")
 Set T = Sheets("Target")
 T.Range("A1").CurrentRegion.Offset(1).Clear
 k = 2
For Each itm In arr
 Set Sh = Sheets(itm)
 Max_ro = Sh.Cells(Rows.Count, 2).End(3).Row
 Set F_rg = Sh.Range("o2").Resize(Max_ro).Find("*", lookat:=1)
 If Not F_rg Is Nothing Then
  Adr1 = F_rg.Row: Adr2 = Adr1
   Do
     T.Range("B" & k).Resize(, 21).Value = _
     Sh.Range("B" & Adr2).Resize(, 21).Value
     T.Range("W" & k) = Sh.Name & ": (" & Adr2 & ")"
     T.Range("A" & k) = k - 1
     k = k + 1
     Set F_rg = Sh.Range("o2").Resize(Max_ro).FindNext(F_rg)
     Adr2 = F_rg.Row
   If Adr2 = Adr1 Then Exit Do
   Loop
  
  
 End If
Next itm
If k > 2 Then
  With T.Range("A2").Resize(k - 2, 23)
    With .Font
     .Size = 14: .Bold = True
    End With
   .InsertIndent 1
   .Borders.LineStyle = 1
   .Interior.ColorIndex = 20
  End With
End If
End Sub

 

 

 

Fares_hasan.xlsm

[فارس حسن]

جزيل الشكر .. لكم اخي سليم 

ونسال الله لكم التوفيق