محتاج كود VBA لاستخراج بيانات خلال فترة محددة

[ehabaf2]

السلام عليكم الاخوة الافاضل

كنت محتاج كود استخراج بيانات من جدول خلال فترة محددة لقسم محدد 

اعتزر لعدم المقدرة على الشرح بالتفصيل و لكن مرفق الملف به كل التفاصل

الف الف شكر لحضراتكم على المجهود المبذول لمساعدة الاعضاء

استخراج بالتاريخ.xlsx

[وجيه شرف الدين]

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

استخراج بالتاريخ.xlsm

[محمد هشام.]

تفضل اخي 

Option Explicit  
Sub FILTRE()
' فلترة البيانات بين تاريخين واسم القسم
Dim i&, R, LastRow As Long, rngCell, c As Range
Dim a(1 To 3)
    a(1) = [BK1]: a(2) = [BK2]: a(3) = [BP1]
    
Dim MyRng  As Range
Dim WSdata As Worksheet: Set WSdata = ThisWorkbook.Sheets("Sheet1")

Application.ScreenUpdating = False
WSdata.Range("BJ5:BY1000").ClearContents
Set MyRng = WSdata.Range("AM2:BD" & WSdata.Cells(WSdata.Rows.Count, "am").End(xlUp).Row)
  
    R = MyRng
    For i = 1 To UBound(R)
If R(i, 17) >= a(1) And R(i, 17) <= a(2) And R(i, 18) = a(3) Then
   
    
WSdata.Range("BJ" & Rows.Count).End(xlUp).Offset(1).Resize(1, 16).Value _
= Array((R(i, 1)), (R(i, 2)), (R(i, 3)), (R(i, 4)), (R(i, 5)), (R(i, 6)), (R(i, 7)), (R(i, 8)), (R(i, 9)), (R(i, 10)), (R(i, 11)), (R(i, 12)), (R(i, 13)), (R(i, 14)), (R(i, 15)), (R(i, 16)))
     
        
        End If
    Next
                                       
 ' تسطير البيانات
LastRow = WSdata.Range("BJ:BY").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 Set rngCell = WSdata.Range("BJ5 :BY" & LastRow)
   WSdata.Range("BJ5:BY1000").Borders.LineStyle = xlNone
    For Each c In rngCell.Rows
  If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
Next
  
   If Application.WorksheetFunction.CountA(WSdata.Range("BJ5:BY5")) = 0 Then
MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه"

End If

Application.ScreenUpdating = True

End Sub

اظافات ممكن تفيدك للاشتغال على الملف بشكل افضل

 

Sub CreateValidation()
'انشاء قوائم التاريخ والقسم تلقائيا بدون تكرار
Dim J, K, lr As Long
Dim a(1 To 2) As String

Dim WSdata As Worksheet: Set WSdata = Worksheets("Sheet1")
lr = WSdata.Range("BC:BD").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

J = WSdata.Range("BC2:BC" & lr): K = WSdata.Range("BD2:BD" & lr)

        J = column(Application.Transpose(J)): a(1) = Join(J, ",")
        K = column(Application.Transpose(K)): a(2) = Join(K, ",")
   
With WSdata.Range("BK1:BK2").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(1)
End With
With WSdata.Range("BP1").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(2)
End With
End Sub
Function column(arr) As Variant
    With Application
    column = .Index(arr, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & _
    UBound(.Match(arr, arr, 0)) & ")")), .Match(arr, arr, 0), 0), "|"), "|", False))
    End With
End Function

وفي حدث ورقة1 انسخ الكود التالي 

Private Sub Worksheet_Change(ByVal Target As Range)
' تحديث القوائم عند الاظافة او التعديل في عمود التاريخ او القسم
On Error Resume Next
lr = Range("BC" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Range("BC2:BC" & lr)) Is Nothing Then
        Application.EnableEvents = False
           Call CreateValidation
        Application.EnableEvents = True
   Exit Sub
End If
' تنفيد الكود عند التغيير في خلية القسم
If Not Intersect(Target, Target.Worksheet.Range("BP1")) Is Nothing Then
    If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub
     Call FILTRE
    Application.EnableEvents = True
      End If
  On Error GoTo 0
  
End Sub

 

استخراج بالتاريخ 2.xlsm

[ehabaf2]

السلام عليكم الاخوة الافاضل

عبارات الشكر لا تفى حقكم لأنكم أكبر منها، فأنتم لكم الفضل في تحويل الفشل إلى نجاح، ورفع العزيمة والمعنوية لدي، فأنتم أهل التميز 

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

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

ربنا يحفظك و يبارك فى حضرتك و اسرتك الكريمة استاذنا الفاضل