استدعاء تقرير بين تاريخين

[الخطيب بيبوو]

عند اختيار مكان الشغل او اسم المقاول بين التاريخين يتم استدعاء البيانات من شيت يومية المقاولين

عمالة نظام جديد.xlsm

[محمد هشام.]

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

Option Explicit
Option Compare Text

Sub FilterContractorData()
    Dim CrWS As Worksheet, dest As Worksheet, OnRng, ColArr, a(1 To 4)
    Const tmp1 = 3, tmp2 = 4, colDate = 1

    Set CrWS = Sheets("يومية المقاولين")
    Set dest = Sheets("تقرير تفصيلى")

    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual

        OnRng = CrWS.Range("B8:Y" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row).Value
        a(1) = dest.[D3].Value: a(2) = dest.[E3].Value
        a(3) = dest.[C6].Value: a(4) = dest.[D6].Value

        ColArr = FiltreTbl(OnRng, a, tmp1, tmp2, colDate, _
            Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24))

        If Not IsEmpty(ColArr) Then
            Dim Lr As Long: Lr = dest.Rows.Count
            dest.Range("A11:T" & Lr).ClearContents
            dest.Range("B11").Resize(UBound(ColArr), UBound(ColArr, 2)).Value = ColArr
            With dest.Range("A11:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row)
                .Value = Evaluate("ROW(" & .Address & ")-10")
            End With
        Else
            MsgBox "لا توجد بيانات تطابق الشروط المحددة", vbExclamation
        End If

        .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
    End With
End Sub

Function FiltreTbl(OnRng, a, tmp1, tmp2, colDate, Optional f)
    Dim cnt(), temp(), b(), n&, j&, i&, k&, r&, vDate

    n = UBound(OnRng, 2)
    If IsMissing(f) Then
        ReDim cnt(0 To n - 1): For k = 0 To n - 1: cnt(k) = k + 1: Next k
    Else: cnt = f
    End If

    j = UBound(cnt): ReDim temp(1 To UBound(OnRng), 1 To j + 1)
    For i = LBound(OnRng) To UBound(OnRng)
        vDate = OnRng(i, colDate)
        If IsDate(vDate) And (a(1) = "" Or OnRng(i, tmp1) = a(1)) And (a(2) = "" Or OnRng(i, tmp2) = a(2)) _
           And (vDate >= a(3) And vDate <= a(4)) Then
            r = r + 1: For k = 0 To j: temp(r, k + 1) = OnRng(i, cnt(k)): Next k
        End If
    Next i

    If r > 0 Then
        ReDim b(1 To r, 1 To j + 1)
        For i = 1 To r: For k = 1 To j + 1: b(i, k) = temp(i, k): Next k: Next i
        FiltreTbl = b
    Else: FiltreTbl = Empty
    End If
End Function

 

عمالة نظام جديد.xlsm

[الخطيب بيبوو]

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

[محمد هشام.]

4 ساعات مضت, الخطيب بيبوو said:

ممكن اخفاء الاعمدة والصفوف الفارغة على قد البيانات فقط

الأعمدة عندك ثابثة لغاية عمود Y  ممكن تخفيها يدويا عادي 

أما الصفوف مادا تقصد هل الغاء تنسيق  الأعمدة الغير مستخدمة كحدف التسطير او اخفائها نهائيا 

[الخطيب بيبوو]

عايز كود اخفاء تلفائى  للصفوف والاعمدة على اساس التاريخ من  و الى واظهار البيانات فقط

 

تم تعديل منذ 1 ساعه بواسطه الخطيب بيبوو

[محمد هشام.]

لم أستوعب طلبك جيدا  هل تفصد إخفائها على ورقة  تقرير تفصيلى  أو  يومية المقاولين

المرجوا إرفاق عينة للنتائج المتوقعة لمزيدا من التوضيح