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

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

السلام عليكم 

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

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

فالمطلوب نسخ الصفوف التي تحقق شرط في 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

  • Like 4
  • Thanks 1
رابط هذا التعليق
شارك

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