حذف عواميد فارغة من التقرير

[واكل]

السلام عليكم 

السادة الزملاء تحية طيبة للكل مرفق ملف اكسيل به بيانات مجمعة والشيت الاخر تقرير بالتاريخ لاظهار بياناته هذا الملف ماخوذ من زميل لنا بالشركة مشكورا على مجهوده  اريد التعديل عليه أنه فى شيت رقم 1 الخاص بالتقرير عند تسجيل التاريخ لعمل التقرير يظهر كل الاعمدة حتى من ليس له بيان اريد ان أظهر من له بيانات فقط  ونفس الكلام عند الفلترة على مكان المكبس

برجاء من سيادتكم الحل وشكرا جزيلا لكم

لا داعي لضغط الملف طالما مساحته صغيره

 

W.xlsm

[واكل]

أرجو من الاخوة الرد والحل

[عبدالله بشير عبدالله]

وعليكم السلام ورخمة الله وبركاته

ربما تفصد اخفاء الاعمدة   وليس الخذف كما ورد في طلبك

الكود يخفى العمود كله فارغ أو كله قيمه تساوي (0 أو 0%) → يخفي العمود بالكامل.

الكود في البداية يظهر كل الأعمدة ثم يعيد إخفاء المناسب

تم ربط الكود مع امر الفلترة 

اظافة التسطير لناتج الفلترة

هذا خسب فهمى لطلبكم

الكود 

Sub فلترة_اخفاء()
    Dim wsSrc As Worksheet, wsDst As Worksheet
    Dim lastRow As Long
    Dim rng As Range, col As Range, c As Range
    Dim hideCol As Boolean
    Dim rngOut As Range
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("المجمع")
    Set wsDst = ThisWorkbook.Sheets("1")
    
    lastRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row
    If lastRow >= 5 Then
        wsDst.Rows("5:" & lastRow).ClearContents
        wsDst.Rows("5:" & lastRow).ClearFormats
    End If
    wsDst.Columns("A:W").Hidden = False

    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "E").End(xlUp).Row
    If lastRow < 2 Then Exit Sub
    
    wsSrc.Range("E1:W" & lastRow).AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=wsDst.Range("Criteria"), _
        CopyToRange:=wsDst.Range("Extract"), _
        Unique:=False
    
    lastRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row
    If lastRow < 5 Then GoTo Done
    
    Set rngOut = wsDst.Range("A5:W" & lastRow)
    
    With rngOut.Borders
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    
    rngOut.EntireColumn.Hidden = False
    For Each col In rngOut.Columns
        hideCol = True
        For Each c In col.Cells
            If Not (isEmpty(c.Value) Or c.Value = 0 Or c.Text = "0%") Then
                hideCol = False
                Exit For
            End If
        Next c
        If hideCol Then col.EntireColumn.Hidden = True
    Next col
    
Done:
    Application.ScreenUpdating = True
End Sub

الملف

W1.xlsm

تحياتي

 

 

[واكل]

شكرا اخي الفاضل كثيرا لمتابعة وجاري التجربة