مطلوب كود استخراج بيانات بالمصفوفات

Sub CollData()

Dim ws As Worksheet, Sh As Worksheet

Dim LR  As Long, i As Long, j As Long, p As Long

Dim Arr As Variant, Tmp As Variant

Dim WF As WorksheetFunction, x As Integer

Set ws = Sheets("الادخال")

Set Sh = Sheets("الاجمالى")

Set WF = WorksheetFunction

LR = ws.Range("B" & Rows.Count).End(3).Row

Arr = ws.Range("A5:E" & LR).Value

ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 1))

For i = 1 To UBound(Arr, 1)

x = WF.CountIf(ws.Range("B5:B" & i + 4), Arr(i, 2))

If x = 1 Then

p = p + 1

For j = 1 To 5

y = y + Tmp(p, 5)

Tmp(p, j) = Arr(i, j)

y = WF.SumIf(ws.Range("B5:B" & LR), Tmp(p, 2), ws.Range("E5:E" & LR))

Tmp(p, 5) = y

Next

End If

Next

If p > 0 Then Sh.Range("A5").Resize(p, UBound(Tmp, 2)).Value = Tmp

End Sub

Sub CollData()

Dim ws As Worksheet, Sh As Worksheet

Dim LR  As Long, i As Long, j As Long, p As Long

Dim Arr As Variant, Tmp As Variant

Dim WF As WorksheetFunction, x As Long

Dim Tim1, Tim2



   Application.ScreenUpdating = False

   Application.DisplayAlerts = False

    Application.EnableEvents = False

      Application.Calculation = xlCalculationManual





Set ws = Sheets("الادخال")

Set Sh = Sheets("استخراج بيانات")

Set WF = WorksheetFunction

LR = ws.Range("a" & ws.Rows.Count).End(3).Row

Tim1 = Sh.Range("A1"): Tim2 = Sh.Range("B1")

Start = Timer

Arr = ws.Range("A4:p" & LR).Value

ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 1))

For i = 1 To UBound(Arr, 1)

x = WF.CountIf(ws.Range("p4:p" & i + 3), Arr(i, 16))

If Arr(i, 1) >= Tim1 And Arr(i, 1) <= Tim2 And x = 1 Then

p = p + 1

For j = 1 To 11

Tmp(p, j) = Arr(i, Choose(j, 16, 2, 3, 4, 5, 6, 8, 9, 11, 12, 12))

y = WF.SumIf(ws.Range("k4:k" & LR), Tmp(p, 9), ws.Range("o4:o" & LR))

Tmp(p, 11) = y

Next

End If

Next



If p > 0 Then Sh.Range("a4").Resize(p, UBound(Tmp, 2)).Value = Tmp



MsgBox Round(Timer - Start, 2) & " Seconds"

     Application.ScreenUpdating = True

     Application.DisplayAlerts = True

      Application.EnableEvents = True

       Application.Calculation = xlCalculationAutomatic



End Sub

Dim LastRow As Long

Dim LastDataRow As Long

 Application.ScreenUpdating = False

Sheets("Data").Select

'Clear Target Area

    LastRow = Sheets("Data").Cells(Rows.Count, "x").End(xlUp).Row

    If LastRow > 2 Then Range("X2:AI" & LastRow).Clear

       

    LastRow = Sheets("Report").Cells(Rows.Count, "a").End(xlUp).Row

    If LastRow > 2 Then Sheets("Report").Range("A2:M" & LastRow).Clear

 

' Activate Filter Criteria1

    Range("V2").Value = Range("B2").Value2

    Range("U2").Value = Range("B2").Value2

    Range("V3").Formula2R1C1 = "=" & Chr(34) & "<=" & Sheets("Report").Range("D1").Value2 & Chr(34)

    Range("U3").Formula2R1C1 = "=" & Chr(34) & ">=" & Sheets("Report").Range("B1").Value2 & Chr(34)

' Performing advance Filter

    LastDataRow = Sheets("Data").Cells(Rows.Count, "a").End(xlUp).Row

    Range("A2:L" & LastDataRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _

        ("U2:V3"), CopyToRange:=Range("x2"), Unique:=True

 

   LastRow = Sheets("Data").Cells(Rows.Count, "x").End(xlUp).Row

   Range("X2:AI" & LastRow).Copy

   Sheets("Report").Select

   Range("A2").Select

   ActiveSheet.Paste

    

    

    Sheets("Data").Range("X2:AI" & LastRow).Clear

    

   LastRow = Sheets("Report").Cells(Rows.Count, "a").End(xlUp).Row

     Sheets("Data").Select

     Range("P2").Copy

    



    Sheets("Report").Select

    Range("m2").Select

    ActiveSheet.Paste

    Sheets("Report").Range("m3:m" & LastRow).Formula = "=SUMIF(data!A$3:A$" & LastDataRow & ",A3,Data!P$3:P$" & LastDataRow & ")"

 

  Application.ScreenUpdating = True