Fetch product name with total quantity with date condition VBA

[sofas]

Hello, I would like help in creating a VBA code I can extract results from excel sheet Source Conditional on the date in the cell E2 I was able to implement this using the formulas in the attached file. Please review it and implement it using VBA code

Classeur1

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com

 

[Alex Blakenburg]

On a copy of your workbook, give this a try:

Sub SummariseProductByDate()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, rngDest As Range
    Dim arrSrc As Variant, arrDest As Variant
    Dim i As Long, j As Long, dateDest As String
    
    Dim dictSrc As Object, dictKey As String
    
    Set shtSrc = Worksheets("Source")
    With shtSrc
        Set rngSrc = .Range("A2:D" & .Cells(Rows.Count, "C").End(xlUp).Row)
        arrSrc = rngSrc.Value2
    End With
    
    Set shtDest = Worksheets("Dest")
    With shtDest
        Set rngDest = .Range("B2:C" & .Cells(Rows.Count, "B").End(xlUp).Row)
        rngDest.Columns(2).ClearContents
        dateDest = CStr(.Range("E1").Value2)
        arrDest = rngDest.Value2
    End With

    Set dictSrc = CreateObject("Scripting.dictionary")
    dictSrc.CompareMode = vbTextCompare
    
    For i = 1 To UBound(arrSrc)
        dictKey = arrSrc(i, 3) & "|" & arrSrc(i, 1)             ' Concatenate Product and Date
        dictSrc(dictKey) = dictSrc(dictKey) + arrSrc(i, 4)
    Next i
    
    For j = 1 To UBound(arrDest)
        dictKey = arrDest(j, 1) & "|" & dateDest            ' Concatenate Product and Date
        If dictSrc.exists(dictKey) Then
            arrDest(j, 2) = dictSrc(dictKey)
        End If
    Next j
    
    rngDest.Columns(2).Value2 = Application.Index(arrDest, 0, 2)

End Sub

 

[sofas]

On a copy of your workbook, give this a try:

Sub SummariseProductByDate()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, rngDest As Range
    Dim arrSrc As Variant, arrDest As Variant
    Dim i As Long, j As Long, dateDest As String
   
    Dim dictSrc As Object, dictKey As String
   
    Set shtSrc = Worksheets("Source")
    With shtSrc
        Set rngSrc = .Range("A2:D" & .Cells(Rows.Count, "C").End(xlUp).Row)
        arrSrc = rngSrc.Value2
    End With
   
    Set shtDest = Worksheets("Dest")
    With shtDest
        Set rngDest = .Range("B2:C" & .Cells(Rows.Count, "B").End(xlUp).Row)
        rngDest.Columns(2).ClearContents
        dateDest = CStr(.Range("E1").Value2)
        arrDest = rngDest.Value2
    End With

    Set dictSrc = CreateObject("Scripting.dictionary")
    dictSrc.CompareMode = vbTextCompare
   
    For i = 1 To UBound(arrSrc)
        dictKey = arrSrc(i, 3) & "|" & arrSrc(i, 1)             ' Concatenate Product and Date
        dictSrc(dictKey) = dictSrc(dictKey) + arrSrc(i, 4)
    Next i
   
    For j = 1 To UBound(arrDest)
        dictKey = arrDest(j, 1) & "|" & dateDest            ' Concatenate Product and Date
        If dictSrc.exists(dictKey) Then
            arrDest(j, 2) = dictSrc(dictKey)
        End If
    Next j
   
    rngDest.Columns(2).Value2 = Application.Index(arrDest, 0, 2)

End Sub

Thank you, sorry I may not have been able to explain the idea more clearly, I need when entering in column a, column 3 data and column sum 4 are felled from the source sheet, provided the date and value entered

 

[Alex Blakenburg]

I am still not understanding what you are after.
Your format only caters for 1 date, and you have a formula that works.
If you make your dest range an excel table it will automatically populate the formula down every time you add a row with a new product.
Alternative prepopulate more rows than you need and get the formula to show "" if the product field is blank.

You could do a worksheet change event but if you don't need it, it just slows down the data entry process.

And for that matter once you have added a number of products and you want to change the date, are you going to remove all the existing products and start entering them again ?

 

[sofas]

I am still not understanding what you are after.
Your format only caters for 1 date, and you have a formula that works.
If you make your dest range an excel table it will automatically populate the formula down every time you add a row with a new product.
Alternative prepopulate more rows than you need and get the formula to show "" if the product field is blank.

You could do a worksheet change event but if you don't need it, it just slows down the data entry process.

And for that matter once you have added a number of products and you want to change the date, are you going to remove all the existing products and start entering them again ?

Thank you for following. I was able to access this code with your help @NateSC It performs what is required well. Is there an idea to implement it when entering data in column (“A”) on the active sheet?

Sub test()
Dim desWS As Worksheet, lr&, lige&
Dim WS As Worksheet: Set WS = Sheets("Source")

For Each desWS In ThisWorkbook.Worksheets

If desWS.Name Like "*-*" Then

With Application
    .ScreenUpdating = False
    .Calculation = xlManual
     desWS.Activate
    
lr = WS.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Set a = WS.Range("A2:A" & lr): Set b = WS.Range("B2:B" & lr)
Set c = WS.Range("C2:C" & lr): Set d = WS.Range("D2:D" & lr)
f = WS.Name

lige = desWS.Cells(Rows.Count, 1).End(xlUp).Row - 1
desWS.Range("B2:C" & lige).ClearContents
 
With desWS.Range("B2:B" & lige)
.Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")"
  .Value = .Value

With desWS.Range("C2:C" & lige)
.Formula2 = "=SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",A2)"
  .Value = .Value

                 WS.Activate
                End With
             End With
       .ScreenUpdating = True
    .Calculation = xlAutomatic
       End With
    End If
Next desWS
End Sub