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

[ميلان]

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

الملف به بعض البيانات لبعض العوائل واذا كان الحل تغيير تنسيق الجدول لا مشكلة لكن هناك بيانات لاعمدة اخرى لم اضعها او ان استطيع حلها عن طريق بيفت تيبل .

test.xlsx

[omar elhosseini]

اخي

اعمل مثال لما تتوقعة للنيجة الفرز ربما يستطيع احد الاخوة المساعدة

[lionheart]

You can change the date in the code

Sub Test()
    Const sReport As String = "Report"
    Dim ws As Worksheet, myDate As Date, lr As Long, r As Long, c As Long, k As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        myDate = CLng(DateSerial(2017, 1, 1))
        ReDim a(1 To (lr - 2) * 7, 1 To 6)
        For r = 3 To lr
            For c = 9 To 27 Step 3
                If ws.Cells(r, c + 1).Value2 >= myDate Then
                    k = k + 1
                    a(k, 1) = ws.Cells(r, 3).Value
                    a(k, 2) = ws.Cells(r, 6).Value
                    a(k, 3) = ws.Cells(r, 7).Value
                    a(k, 4) = ws.Cells(r, c).Value
                    a(k, 5) = ws.Cells(r, c + 1).Value
                    a(k, 6) = ws.Cells(r, c + 2).Value
                End If
            Next c
        Next r
        If k > 0 Then
            On Error Resume Next
                Application.DisplayAlerts = False
                    Worksheets(sReport).Delete
                Application.DisplayAlerts = True
            On Error GoTo 0
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = sReport
            With Worksheets(sReport)
                .DisplayRightToLeft = True
                .Range("A1").Resize(, 6).Value = Array("Father Name", "Mother Name", "Place", "Child", "Birth Date", "ID")
                .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a
                .Columns.AutoFit
            End With
        End If
    Application.ScreenUpdating = True
    MsgBox "Done...", 64, "LionHeart"
End Sub

 

[ميلان]

جزاك الله خير الجزاء ولكن لا اعرف كيفية اضافة الكود بشكل صحيح 

 

[محمد يوسف ابو يوسف]

السلام عليكم

تفضل

يجب عليك تغير امتداد الملف ليصبح هكذا xlsm.

الملف test.xlsm

[ميلان]

كل الشكر والتقدير والاحترام استاذ محمد تم الأمر بنجاح🌹🌹🌹🌹

أستاذي الفاضل مراجعة لما تفضلت علي واجهت مشكلة بأنه طلب مني أطفال ما بين تاريخين مثلا أطفال 2015 وحتى 2019 بخلاف ما تكرمت علي في الحل حيث أن الكود يعطيني نتيجة من تاريخ معين وحتى تاريخ اليوم 

فهل يمكن تعديل الكود جزاك الله خير الجزاء وزادك الله علما استاذي أنت وباقي الأخوة 

[حسونة حسين]

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

عدل هذا السطر 

If ws.Cells(r, c + 1).Value2 >= myDate Then

ليصبح هكذا

If ws.Cells(r, c + 1).Value2 >= myDate and If ws.Cells(r, c + 1).Value2 <= CLng(DateSerial(2019, 1, 1)) Then