فلتر حسب الشهر

[اشرف سعيد السويسي]

المطلوب عمل فلتر حسب الشهر 

999898.xlsx

[أبوعيد]

السلام عليكم

أخي الفلترة موجودة بالفعل , الرجاء الشرح بتفصيل أكثر

[اشرف سعيد السويسي]

ارغب بالفلترة في الصفحة رقم 2

 

[محمد هشام.]

ممكن توضح طلبك اكثر  او ارفاق عينة لشكل النتيجة المتوقعة

 

[اشرف سعيد السويسي]

المرفق بالنتيجة في صفحة 2

وعند كل تغيير في التاريخ (فبراير ) تظهر النتائج

999898.xlsx

[محمد هشام.]

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

Sub Filter_month()
Dim lr&, i&, j&, c&
Dim arr As Variant, K As Variant
Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("1")
Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("2")

lastrow = desWS.Range("b" & Rows.Count).End(xlUp).Row
 clé = desWS.[L2]
 If clé = 0 Then MsgBox "المرجوا تحديد شهر الفلترة", vbExclamation: Exit Sub
 Application.ScreenUpdating = False
  lr = WS.Range("B" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    arr = WS.Range("A3:L" & lr).Value
    ReDim K(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    j = 1
    For i = LBound(arr, 1) To UBound(arr, 1)
    If Month(arr(i, 2)) = Month(clé) Then
    desWS.Range("B5:M" & Rows.Count).ClearContents
     For c = LBound(arr, 2) To UBound(arr, 2)
        K(j, c) = arr(i, c)
    Next c
    j = j + 1
        End If
     Next i
    desWS.Range("b5").Resize(j - 1, UBound(K, 2)).Value = K
     If Err <> 0 Then MsgBox "لا توجد بيانات لشهر" & " :" & Month(clé), vbExclamation, "admin"
End Sub

 

 

Filter_month.xlsb

[محمد هشام.]

تفضل حل اخر لاثراء الموضوع 

Sub Filter_month2()
Dim Cpt As Long, rgFound As Range
Dim cel As Range, Rng As Range, Clé As Range
Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("1")
Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("2")

  lastRow = WS.Range("B" & Rows.Count).End(xlUp).Row
  Set Clé = desWS.Range("L2")
  Set Rng = WS.Range("B3:B" & lastRow)
  For Each cel In Rng
    If Month(cel) = Month(Clé) Then
      Set rgFound = cel
      Exit For
    End If
  Next cel

  If rgFound Is Nothing Then
 MsgBox "لا توجد بيانات لشهر" & " :" & Month(Clé), vbOKOnly + vbExclamation, "admin"
      
      Exit Sub
  End If
desWS.Range("B5:M" & Rows.Count).ClearContents
For Col = 3 To lastRow
If IsDate(WS.Range("B" & Col).Value) = True Then
If Month(WS.Range("B" & Col).Value) = Month(Clé) Then
     Cpt = desWS.Range("b" & Rows.Count).End(xlUp).Row + 1
    desWS.Range("B" & Cpt & ":M" & Cpt).Value = WS.Range("A" & Col & ":L" & Col).Value
      End If
   End If
Next
Application.ScreenUpdating = True
End Sub