Populate report from date to date for many ID

Hello
I search for macro to deal for each sheet .
in two sheets I have data for items in columns D:F and the price in column H . so what I want when merge duplicates items based on matching columns D: F and when repeat the same item with different price should use price averages but when merge items should be separated for each sheet alone , also when merge quantity should just be for SVR sheet (means ignoring QTY totally in SR sheet when merge as I did last sheet .
when merge data should be based on two cells (dates) should merge within two dates in E2,G2 . if the E2,G2 are empty then should be empty from row 5 .every time run the macro should clear data from row5 before brings the data without delete formatting and borders , not repeat to the bottom the same data have already copied.
in REPORT sheet SVR header is averages prices from column H for SVR sheet ,SR header is averages prices from column H for SR sheet and in last row(TOTAL) should sum the columns I,J,K and in column L will subtract and sum for I:K as I put the formulas .
if they data are existed in SVR but not in SR should show in REPORT sheet , but if they data are existed in SR ,not in SVR should NOT show in REPORT sheet .
finally when copy data to report sheet I want keep the formatting (numbers,borders....) .
thanks

Hey there abdo...
The date population part I do not understand...
This renders your expected result though...

Hi sintek

The date population part I do not understand...

I want creating report based on two dates . should not merge for all ID without depend on two dates .
just merge based what data start and end date also between two dates and ignore merging before start date and after end date and when dates cells are empty then should not show anything
edited file to understand how could be

Yet you do not provide the between dates?

Need an entire different code approach for this...Will revert back a bit later...Off to work now...

Based on these dates, your output result is incorrect...

And another error...see green value below...

Untitled.png

Option Explicit

Sub Demo()
    Dim ar As Variant, arr As Variant
    Dim i As Long, j As Long, k As Long, n As Long
    Dim str As String
    Dim sdate As Date, fdate As Date
    Dim ws()
    ws = Array("SVR", "SR")
    ReDim arr(1 To 100, 1 To 10)
    
    With Sheets("Report")
        sdate = .[E2]: fdate = .[G2]
    End With
    
    n = 0
    
    With CreateObject("Scripting.Dictionary")
    
        For j = 0 To 1
        
            With Sheets(ws(j))
                ar = .Cells(1, 1).Offset(1, 0).CurrentRegion
            End With
            
            For i = 2 To UBound(ar, 1)
            
               If ar(i, 2) >= sdate And ar(i, 2) <= fdate Then
            
                str = ar(i, 4) & ar(i, 5) & ar(i, 6)
                If str <> vbNullString Then
                    If Not .Exists(str) Then
                        n = n + 1
                       .Add str, n
                       .Item(str) = n
                        arr(n, 1) = n
                        For k = 4 To 6
                            arr(n, k - 2) = ar(i, k)
                        Next k
                        arr(n, 5) = arr(n, 5) + ar(i, 7)
                        arr(n, 6) = arr(n, 6) + ar(i, 8)
                        arr(n, 9) = arr(n, 9) + 1
                        
                    Else
                         If j = 0 Then
                            arr(.Item(str), 5) = arr(.Item(str), 5) + ar(i, 7)
                            arr(.Item(str), 6) = arr(.Item(str), 6) + ar(i, 8)
                            arr(.Item(str), 9) = arr(.Item(str), 9) + 1
                         Else
                            arr(.Item(str), 7) = arr(.Item(str), 7) + ar(i, 8)
                            arr(.Item(str), 10) = arr(.Item(str), 10) + 1
                         End If
                    End If
                End If
              End If
            Next i
            
        Next j
    End With
    
    For j = 1 To n
        arr(j, 6) = arr(j, 6) / arr(j, 9)
        If arr(j, 10) > 0 Then arr(j, 7) = arr(j, 7) / arr(j, 10) Else arr(j, 7) = 0
        arr(j, 8) = (arr(j, 6) - arr(j, 7)) * arr(j, 5)
    Next j
        
    
    With Sheets("Report")
        .[E4].CurrentRegion.Clear
        .[E4].Resize(1, 8) = Array("ITEM", "BRAND", "TYPE", "ORIGIN", "QTY", "SVR", "SR", "NET")
        .[E4].Resize(1, 8).Font.Bold = True
        .[E5].Resize(n, 8) = arr
        .Cells(5 + n, 5) = "TOTAL": .Cells(5 + n, 5).Font.Bold = True
        .Cells(5 + n, 9).Resize(, 3).Formula = "=SUM(I5:I" & 5 + n - 1 & ")"
        .Cells(5 + n, 12) = .Cells(5 + n, 9) * .Cells(5 + n, 10) - .Cells(5 + n, 11)
        .[E4].Resize(n + 2, 8).Borders.Weight = 2
        .Columns(10).Resize(, 3).NumberFormat = "#0,0.00"
        .Columns(5).Resize(, 8).HorizontalAlignment = xlCenter
    End With
End Sub

See attached

Option Explicit

Sub Demo()
    Dim ar As Variant, arr As Variant
    Dim i As Long, j As Long, k As Long, n As Long
    Dim str As String
    Dim sdate As Date, fdate As Date
    Dim ws()
    ws = Array("SVR", "SR")
    ReDim arr(1 To 100, 1 To 10)
    
    With Sheets("Report")
        sdate = .[E2]: fdate = .[G2]
    End With
    
    n = 0
    
    With CreateObject("Scripting.Dictionary")
    
        For j = 0 To 1
        
            With Sheets(ws(j))
                ar = .Cells(1, 1).Offset(1, 0).CurrentRegion
            End With
            
            For i = 2 To UBound(ar, 1)
            
               If ar(i, 2) >= sdate And ar(i, 2) <= fdate Then
            
                str = ar(i, 4) & ar(i, 5) & ar(i, 6)
                If str <> vbNullString Then
                      If Not .Exists(str) Then
                           If j = 1 Then GoTo nexti
                            n = n + 1
                           .Add str, n
                           .Item(str) = n
                            arr(n, 1) = n
                            For k = 4 To 6
                                arr(n, k - 2) = ar(i, k)
                            Next k
                            arr(n, 5) = arr(n, 5) + ar(i, 7)
                            arr(n, 6) = arr(n, 6) + ar(i, 8)
                            arr(n, 9) = arr(n, 9) + 1
                            
                        Else
                             If j = 0 Then
                                arr(.Item(str), 5) = arr(.Item(str), 5) + ar(i, 7)
                                arr(.Item(str), 6) = arr(.Item(str), 6) + ar(i, 8)
                                arr(.Item(str), 9) = arr(.Item(str), 9) + 1
                             Else
                                arr(.Item(str), 7) = arr(.Item(str), 7) + ar(i, 8)
                                arr(.Item(str), 10) = arr(.Item(str), 10) + 1
                             End If
                         End If
                    End If
                End If
              
nexti:
            Next i
            
        Next j
    End With
    
    For j = 1 To n
        arr(j, 6) = arr(j, 6) / arr(j, 9)
        If arr(j, 10) > 0 Then arr(j, 7) = arr(j, 7) / arr(j, 10) Else arr(j, 7) = 0
        arr(j, 8) = (arr(j, 6) - arr(j, 7)) * arr(j, 5)
    Next j
        
    
    With Sheets("Report")
        .[E4].CurrentRegion.Clear
        .[E4].Resize(1, 8) = Array("ITEM", "BRAND", "TYPE", "ORIGIN", "QTY", "SVR", "SR", "NET")
        .[E4].Resize(1, 8).Font.Bold = True
        .[E5].Resize(n, 8) = arr
        .Cells(5 + n, 5) = "TOTAL": .Cells(5 + n, 5).Font.Bold = True
        .Cells(5 + n, 9).Resize(, 3).Formula = "=SUM(I5:I" & 5 + n - 1 & ")"
        .Cells(5 + n, 12) = .Cells(5 + n, 9) * .Cells(5 + n, 10) - .Cells(5 + n, 11)
        .[E4].Resize(n + 2, 8).Borders.Weight = 2
        .Columns(10).Resize(, 3).NumberFormat = "#0,0.00"
        .Columns(5).Resize(, 8).HorizontalAlignment = xlCenter
    End With
End Sub

Why would you run macro with these fields empty ?

With Sheets("Report")
        sdate = .[E2]: fdate = .[G2]
        If sdate = 0 Then
            .Range("E5:L" & .Cells(Rows.Count, "E").End(xlUp).Row).Clear
             Exit Sub
        End If
    End With

Sub J3v16v2()
Dim ShtArr, Data, Chk, X0, X1, X2, Temp, StDt As Date, EdDt As Date
Dim Dict As Object, Str As String, i As Long, ii As Long, x As Long
ShtArr = [{"SVR","SR"}]: Set Dict = CreateObject("Scripting.Dictionary")
ReDim Temp(1 To 1000, 1 To 7)
With Sheets("Report")
    StDt = .Range("E2"): EdDt = .Range("G2")
    If StDt = 0 Then .Rows(5 & ":" & .Rows.Count).Delete
    Exit Sub
End With
For i = 1 To 2
    With Sheets(ShtArr(i)).Cells(1).CurrentRegion
        Data = .Value
        For ii = 2 To UBound(Data)
            If Data(ii, 4) <> "" Then
                Str = Data(ii, 4) & Data(ii, 5) & Data(ii, 6)
                X0 = Application.CountIfs(.Columns(4), Data(ii, 4), .Columns(5), Data(ii, 5), .Columns(6), Data(ii, 6), .Columns(2), ">=" & "" & CDbl(StDt) & "", .Columns(2), "<=" & "" & CDbl(EdDt) & "")
                If X0 > 0 Then
                    If i = 2 Then
                        With Sheets(ShtArr(i - 1)).Cells(1).CurrentRegion
                            X0 = Application.CountIfs(.Columns(4), Data(ii, 4), .Columns(5), Data(ii, 5), .Columns(6), Data(ii, 6), .Columns(2), ">=" & "" & CDbl(StDt) & "", .Columns(2), "<=" & "" & CDbl(EdDt) & "")
                            If X0 = 0 Then GoTo Nxt
                        End With
                    End If
                    X1 = Application.SumIfs(.Columns(7), .Columns(4), Data(ii, 4), .Columns(5), Data(ii, 5), .Columns(6), Data(ii, 6), .Columns(2), ">=" & "" & CDbl(StDt) & "", .Columns(2), "<=" & "" & CDbl(EdDt) & "")
                    X2 = Application.SumIfs(.Columns(8), .Columns(4), Data(ii, 4), .Columns(5), Data(ii, 5), .Columns(6), Data(ii, 6), .Columns(2), ">=" & "" & CDbl(StDt) & "", .Columns(2), "<=" & "" & CDbl(EdDt) & "") / X0
                    If Not Dict.exists(Str) Then
                        Dict.Add Str, "": x = x + 1
                        Temp(x, 1) = Str: Temp(x, 2) = Data(ii, 4)
                        Temp(x, 3) = Data(ii, 5): Temp(x, 4) = Data(ii, 6)
                        Temp(x, 5) = X1: Temp(x, IIf(i = 1, 6, 7)) = X2
                    Else
                        If i = 2 Then Chk = Application.Match(Str, Application.Index(Temp, , 1), 0): Temp(Chk, 7) = X2
                    End If
                End If
            End If
Nxt:
        Next ii
    End With
Next i
With Sheets("Report")
    .Rows(5 & ":" & .Rows.Count).Delete
    .Cells(5, 5).Resize(x, 7) = Temp
    .Cells(5, 5).Resize(x).Value = Evaluate("Row(1:" & x & ")")
    .Cells(5, 12).Resize(x + 1).Formula = "=I5*J5-K5"
    .Cells(5, 10).Resize(x + 1, 3).NumberFormat = "#,0.00"
    .Cells(5 + x, 9).Resize(, 3).Formula = "=SUM(I5:I" & 5 + x - 1 & ")"
    .Cells(5 + x, 5) = "TOTAL"
    With .Cells(5, 5).CurrentRegion
        .Columns(7).SpecialCells(xlCellTypeBlanks) = 0
        .Borders.Weight = 2
        .Columns(1).Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
End With
End Sub

I don't have any problem deleting the dates and then adding dates again!

You will get an error if there is no data in the dates used.

Add highlighted line

 If n = 0 Then Exit Sub
    
    For j = 1 To n
        arr(j, 6) = arr(j, 6) / arr(j, 9)
        If arr(j, 10) > 0 Then arr(j, 7) = arr(j, 7) / arr(j, 10) Else arr(j, 7) = 0
        arr(j, 8) = (arr(j, 6) - arr(j, 7)) * arr(j, 5)
    Next j

oops...my bad...

If StDt = 0 Then .Rows(5 & ":" & .Rows.Count).Delete: Exit Sub

No it does not: if you do not enter dates it will clear the data but if you enter dates for which there is no results then the added test will/should prevent the error.

I am out!

Wrong (not updated) macro: see post #15.

YES:

Sub Demo()
    Dim ar As Variant, arr As Variant
    Dim i As Long, j As Long, k As Long, n As Long
    Dim str As String
    Dim sdate As Date, fdate As Date
    Dim ws()
    ws = Array("SVR", "SR")
    ReDim arr(1 To 100, 1 To 10)
    
    With Sheets("Report")
        sdate = .[E2]: fdate = .[G2]
        If sdate = 0 Then
            .Range("E5:L" & .Cells(Rows.Count, "E").End(xlUp).Row).Clear
             Exit Sub
        End If
    End With
    
    
    n = 0
    
    With CreateObject("Scripting.Dictionary")
    
        For j = 0 To 1
        
            With Sheets(ws(j))
                ar = .Cells(1, 1).Offset(1, 0).CurrentRegion
            End With
            
            For i = 2 To UBound(ar, 1)
            
               If ar(i, 2) >= sdate And ar(i, 2) <= fdate Then
            
                str = ar(i, 4) & ar(i, 5) & ar(i, 6)
                If str <> vbNullString Then
                      If Not .Exists(str) Then
                           If j = 1 Then GoTo nexti
                            n = n + 1
                           .Item(str) = n
                            arr(n, 1) = n
                            For k = 4 To 6
                                arr(n, k - 2) = ar(i, k)
                            Next k
                            arr(n, 5) = arr(n, 5) + ar(i, 7)
                            arr(n, 6) = arr(n, 6) + ar(i, 8)
                            arr(n, 9) = arr(n, 9) + 1
                            
                        Else
                             If j = 0 Then
                                arr(.Item(str), 5) = arr(.Item(str), 5) + ar(i, 7)
                                arr(.Item(str), 6) = arr(.Item(str), 6) + ar(i, 8)
                                arr(.Item(str), 9) = arr(.Item(str), 9) + 1
                             Else
                                arr(.Item(str), 7) = arr(.Item(str), 7) + ar(i, 8)
                                arr(.Item(str), 10) = arr(.Item(str), 10) + 1
                             End If
                         End If
                    End If
                End If
              
nexti:
            Next i
            
        Next j
    End With
    
    If n = 0 Then Exit Sub
    
    For j = 1 To n
        arr(j, 6) = arr(j, 6) / arr(j, 9)
        If arr(j, 10) > 0 Then arr(j, 7) = arr(j, 7) / arr(j, 10) Else arr(j, 7) = 0
        arr(j, 8) = (arr(j, 6) - arr(j, 7)) * arr(j, 5)
    Next j
        
    
    With Sheets("Report")
        .[E4].CurrentRegion.Clear
        .[E4].Resize(1, 8) = Array("ITEM", "BRAND", "TYPE", "ORIGIN", "QTY", "SVR", "SR", "NET")
        .[E4].Resize(1, 8).Font.Bold = True
        .[E5].Resize(n, 8) = arr
        .Cells(5 + n, 5) = "TOTAL": .Cells(5 + n, 5).Font.Bold = True
        .Cells(5 + n, 9).Resize(, 3).Formula = "=SUM(I5:I" & 5 + n - 1 & ")"
        .Cells(5 + n, 12) = .Cells(5 + n, 9) * .Cells(5 + n, 10) - .Cells(5 + n, 11)
        .[E4].Resize(n + 2, 8).Borders.Weight = 2
        .Columns(10).Resize(, 3).NumberFormat = "#0,0.00"
        .Columns(5).Resize(, 8).HorizontalAlignment = xlCenter
    End With
End Sub