مسح الصف الذى به 0

[yara ahmed]

اخواتى احتاج ماكرو لمسح الصف الذى به الرقم 0 بدا من الصفحة الرابعة

ومن الصف 5 مع خالص حبى وشكرى

او تعديل الكود هذا واضافة شرط وجود 0 فى العمود e5:i500 ليتم المسح

Sub Dell()

    Dim ws As Worksheet
      For Each ws In ThisWorkbook.Worksheets
        With ws
                If .Name = "report" Or _
                   .Name = "report2" Or _
                    .Name = "report3" Or _
                   .Name = "report4" Or _
                   .Name = "report5" Or _
                   .Name = "report" Then
                Else
                
                 .Range("A5:J50000").ClearContents
                End If
        End With
    Next ws
  Else
End If
End Sub

مسح الصف الذى به 0.xlsm

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

ليست المرة الأولى التي اقول فيها

يجب رفع ملف فيه بيانات لا أوراق فارغة 

[yara ahmed]

اشرقت الانوار يا باشا

انا اضفت بيانات تمام

الريبورتات فارغة لا داعى املاءها اريد استثناء هذه الصفحات من تطبيق المكرو

اريد اذا كان الخلية بالعمود من E5 الى I500 اذا كانت 0

يتم حذف السطر كله

مشكور ياباشا واوعى تزعل منى انت كريم وجميل استاذ سليم ربنا يكرمك يارب

مسح الصف الذى به 0.xlsm

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

جربي هذا الكود

Option Explicit

Sub del_zeros()
Dim sh As Worksheet
Dim curt As Range
Dim rg_to_del As Range
Dim F_rg As Range
Dim Ro%, i%

Set sh = Sheets("sheet4")
Ro = sh.Cells(Rows.Count, 1).End(3).Row
If Ro < 5 Then Exit Sub
Set curt = sh.Range("E5:I" & Ro)
 curt.Interior.ColorIndex = xlNone
 For i = 1 To curt.Rows.Count
   Set F_rg = curt.Rows(i).Find(0, lookat:=1)
   If F_rg Is Nothing Then GoTo next_row
    If rg_to_del Is Nothing Then
     Set rg_to_del = curt.Rows(i)
     Else
     Set rg_to_del = Union(rg_to_del, curt.Rows(i))
    End If
next_row:
 Next
 '+++++++++++++++++++++++++
         If Not rg_to_del Is Nothing Then

'        rg_to_del.EntireRow.Delete
          
    
          rg_to_del.Interior.ColorIndex = 6
          
          End If
   Set rg_to_del = Nothing
 
End Sub

الكود يقوم بتلوين الصقف المطلوب 

اذا اردت حذفها استبدلي ما موجود في المربع المربع الأجمر بما هو موجود في المربع الأزرق (الصورة)

[yara ahmed]

تم التطبيق على صفحة واحدة اخى 

اريده يتم التطبيق على كل الصفحات ماعدا صفحات التقارير 

كل حبى وشكرى لك اخى

[yara ahmed]

حاولت اعدل بس فى حاجة غلط مع الشكر الوفير

Option Explicit

Sub del_zeros()
Dim sh As Worksheet
Dim curt As Range
Dim rg_to_del As Range
Dim F_rg As Range
Dim Ro%, i%
      For Each sh In ThisWorkbook.Worksheets
        With sh
                If .Name = "report" Or _
                   .Name = "report2" Or _
                    .Name = "report3" Or _
                   .Name = "report4" Or _
                   .Name = "report5" Or _
                   .Name = "report" Then
                Else
 
Ro = sh.Cells(Rows.Count, 1).End(3).Row
If Ro < 5 Then Exit Sub
Set curt = sh.Range("E5:I" & Ro)
 curt.Interior.ColorIndex = xlNone
 For i = 1 To curt.Rows.Count
   Set F_rg = curt.Rows(i).Find(0, lookat:=1)
   If F_rg Is Nothing Then GoTo next_row
    If rg_to_del Is Nothing Then
     Set rg_to_del = curt.Rows(i)
     Else
     Set rg_to_del = Union(rg_to_del, curt.Rows(i))
    End If
next_row:
 Next
 '+++++++++++++++++++++++++
         If Not rg_to_del Is Nothing Then

'        rg_to_del.EntireRow.Delete
          
    
          rg_to_del.Interior.ColorIndex = 6
          
          End If
            

   Set rg_to_del = Nothing
  
End Sub

خالص الدعاء لك والله

 

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

تم التعدبل

Option Explicit

Sub del_zeros_()
Dim sh As Worksheet
Dim curt As Range
Dim rg_to_del As Range
Dim F_rg As Range
Dim Ro%, i%

For Each sh In Sheets
   If sh.Name Like "report*" Then GoTo next_sheet
      
      Ro = sh.Cells(Rows.Count, 1).End(3).Row
      sh.Range("A4").Resize(, 10) = vbNullString
      Set curt = sh.Range("E5:I" & Ro)
      curt.Interior.ColorIndex = xlNone

For i = 1 To curt.Rows.Count
      Set F_rg = curt.Rows(i).Find(0, lookat:=1)
      If F_rg Is Nothing Then GoTo next_row
          If rg_to_del Is Nothing Then
             Set rg_to_del = curt.Rows(i)
          Else
             Set rg_to_del = Union(rg_to_del, curt.Rows(i))
          End If
next_row:
Next i
      
      If Not rg_to_del Is Nothing Then
      '  rg_to_del.Delete
      
      rg_to_del.Interior.ColorIndex = 35
      
      End If
      Set rg_to_del = Nothing
next_sheet:
Next
End Sub

 

[yara ahmed]

تسلم ايدك الله ينور تمام يا ملك الروائع لا حرمنامنك ابداااااااااااااااااا

تعيش يارب يخليك

كل حبى وشكرى لك اخى الغالى