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

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

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

عمالة نظام جديد.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  ممكن تخفيها يدويا عادي 

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

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

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

 

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

[محمد هشام.]

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

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

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

على ورقة التقرير التفصيلى

 

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

فيه مشكلة  1- تكرار   قيمة الواصل فى  كل التقرير 

                  2- التنسيقات الجداول

                      3- عند اختيار  المقاول احمد شبل  لا يمسح التقرير 

 

عمالة نظام 2025_2026.xlsm

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

[محمد هشام.]

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

فيه مشكلة  1- تكرار   قيمة الواصل فى  كل التقرير

dest.Range("A11:T" & Lr).ClearContents =========>  dest.Range("A11:Y" & Lr).ClearContents

 

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

2- التنسيقات الجداول

Private Sub ShFormat(ByRef dest As Worksheet, ByVal Col As String)
    Dim lastRow As Long
    lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row
    With dest.Range("A11:Y" & lastRow).Borders
        .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic
    End With
End Sub

 

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

3- عند اختيار  المقاول احمد شبل  لا يمسح التقرير

Dim Lr As Long: Lr = dest.Rows.Count
        With dest.Range("A11:Y" & Lr)
            .ClearContents: .Borders.LineStyle = xlNone
        End With

 

عمالة نظام 2025_2026.xlsm

[محمد هشام.]

 

 

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

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

Option Explicit
Option Compare Text
Sub FilterContractorData()
    Dim CrWS As Worksheet, dest As Worksheet, c As Long, OnRng, ColArr, a(1 To 4)
    Const tmp1 = 3, tmp2 = 4, colDate = 1
    Dim col As Range, dataRng As Range, lastCol As Long: lastCol = 25
    Set CrWS = Sheets("يومية المقاولين")
    Set dest = Sheets("تقرير تفصيلى")
    Dim lastRow As Long: lastRow = dest.Rows.Count
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual

        With dest
            .Range("A11:Y" & lastRow).ClearContents
            .Range("A11:Y" & lastRow).Borders.LineStyle = xlNone
        End With

        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
            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

            Call ShFormat(dest, "A:Y")
            Set dataRng = dest.Range("A11:Y" & lastRow)
            For c = 1 To lastCol
                If Application.WorksheetFunction.CountA(dest.Range(dest.Cells(11, c), dest.Cells(lastRow, c))) = 0 Then
                    dest.Columns(c).Hidden = True
                Else
                    dest.Columns(c).Hidden = False
                End If
            Next c

        Else
            MsgBox "لا توجد بيانات تطابق الشروط المحددة", vbExclamation
        End If

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

 

v3-عمالة نظام 2025_2026.xlsm

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

تسلم ايدك بجد  الله ينور