ترحيل الارقام بدون تكرار + الجمع بشروط (الرقم + المخول + بين تاريخين )

[sabah20267]

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

الجمع بين تاريخين بشروط اربع.xlsx

[lionheart]

The total number 300000 is not clear, how do you calculate that manually

[sabah20267]

السلام عليكم .. ارجو التوضيح

الجمع بين تاريخين بشروط اربع.xlsx

[lionheart]

Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet, r As Range, txt As String, i As Long
    Set ws = ThisWorkbook.Worksheets(1)
    Set sh = ThisWorkbook.Worksheets(2)
    sh.Range("A3:C" & Rows.Count).ClearContents
    Set r = ws.Range("F2:M" & ws.Cells(Rows.Count, "F").End(xlUp).Row)
    a = r.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If a(i, 8) = sh.Range("A1").Value Then
                txt = Join(Array(a(i, 2), a(i, 3)), Chr(2))
                If Not .Exists(txt) Then
                    .Item(txt) = .Count + 1
                    a(.Count, 1) = a(i, 2)
                    a(.Count, 2) = a(i, 3)
                    a(.Count, 3) = Evaluate("SUMIFS('" & ws.Name & "'!" & r.Columns(4).Address & ",'" & ws.Name & "'!" & r.Columns(1).Address & ","">=""&" & "'" & sh.Name & "'!" & Range("C1").Address & ", '" & ws.Name & "'!" & r.Columns(1).Address & ",""<="" &" & "'" & sh.Name & "'!" & Range("D1").Address & ",'" & ws.Name & "'!" & r.Columns(2).Address & "," & Chr(34) & a(.Count, 1) & Chr(34) & ",'" & ws.Name & "'!" & r.Columns(3).Address & "," & Chr(34) & a(.Count, 2) & Chr(34) & ")")
                End If
            End If
        Next i
        i = .Count
    End With
    sh.Range("A3").Resize(i, 3).Value = a
End Sub

 

[sabah20267]

جزيت خيرا .. مشكور