Filter a table and then copy the row with the subtotals to another sheet

[winstela]

Hi All,

Hope you can help me.

I have a table, and above the table I have subtotal formulas. I want to be able to filter by 2 columns say (Date) and (Product). then copy just the subtotals to a new sheet.

I have found code that copies the data in the table based on date ranges to a new workbook but I am struggling to add another criteria and then just to copy the row with the subtotals in

I know I can put in a pivot table but my end destination workbook is struggling with the getpivotdata formula.

Sample Data Sheet

Sample SUM Sheet. This will have the values from the Data sheet Row 1

Below is Data sheet filtered on Product A & date March

Below is the code that asks for 2 date ranges and then copies the filtered data to another workbook

Option Explicit

'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
    
    Dim strStart As String, strEnd As String, strPromptMessage As String
    
    'Prompt the user to input the start date
    strStart = InputBox("Please enter the start date")
    
    'Validate the input string
    If Not IsDate(strStart) Then
        strPromptMessage = "Oops! It looks like your entry is not a valid " & _
                           "date. Please retry with a valid date..."
        MsgBox strPromptMessage
        Exit Sub
    End If
    
    'Prompt the user to input the end date
    strEnd = InputBox("Please enter the end date")
    
    'Validate the input string
    If Not IsDate(strStart) Then
        strPromptMessage = "Oops! It looks like your entry is not a valid " & _
                           "date. Please retry with a valid date..."
        MsgBox strPromptMessage
        Exit Sub
    End If
    
    'Call the next subroutine, which will do produce the output workbook
    Call CreateSubsetWorkbook(strStart, strEnd)
    
End Sub

'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
    
    Dim wbkOutput As Workbook
    Dim wksOutput As Worksheet, wks As Worksheet
    Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
    Dim rngFull As Range, rngResult As Range, rngTarget As Range
    
    'Set references up-front
    lngDateCol = 2 '<~ we know dates are in column B
    Set wbkOutput = Workbooks.Add
    'Set wks = ThisWorkbook.Worksheets("Data")
    Set wks = Workbooks("Test.xlsm").Worksheets("Data")
    'Loop through each worksheet
   'For Each wks In ThisWorkbook.Worksheets
        With wks
        
            'Create a new worksheet in the output workbook
            Set wksOutput = wbkOutput.Sheets.Add
            'wksOutput.Name = wks.Name
            wksOutput.Name = "New"
            'Create a destination range on the new worksheet that we
            'will copy our filtered data to
            Set rngTarget = wksOutput.Cells(1, 1)
        
            'Identify the data range on this sheet for the autofilter step
            'by finding the last row and the last column
            lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                 SearchOrder:=xlByRows, _
                                 SearchDirection:=xlPrevious).Row
            lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                 SearchOrder:=xlByColumns, _
                                 SearchDirection:=xlPrevious).Column
            Set rngFull = .Range(.Cells(4, 1), .Cells(lngLastRow, lngLastCol))
            
            'Apply a filter to the full range to get only rows that
            'are in between the input dates
            With rngFull
                .AutoFilter Field:=lngDateCol, _
                            Criteria1:=">=" & StartDate, _
                            Criteria2:="<=" & EndDate
                
                'Copy only the visible cells and paste to the
                'new worksheet in our output workbook
                Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
                rngResult.Copy Destination:=rngTarget
            End With
            
         'With wks
            'Clear the autofilter safely
            .AutoFilterMode = False
           ' If .FilterMode = True Then
            '.ShowAllData
              
   ' If wks.AutoFilterMode Or wks.FilterMode Then
   ' wks.ShowAllData
 Call ClearTableFilters
    
    'Let the user know our macro has finished!
    MsgBox "Data transferred!"

End With
End Sub

Thanks

 

[BSALV]

just to give you a clou, because i don't know where you want to copy your date

 With rngFull
               .AutoFilter Field:=lngDateCol, Criteria1:=">=" & StartDate, Criteria2:="<=" & EndDate
               .AutoFilter 1, "MyProduct"                       'suppose the product column is column 1 and the product, you want to filter is "MyProduct"

               Set csubtotals = wks.Range("D1:U1")
               Set cdest = Sheets("OtherSheet").Range("A" & Rows.Count).End(xlUp).Offset(1)     'next free A-cell in that other sheet
               With cdest
                    .Value = "Myproduct"                        '1st cell = productname
                    .Offset(, 1).Value = StartDate              '2nd cell = for example the date
                    .Offset(, 2).Resize(, csubtotals.Columns.Count).Value = csubtotals.Value     '3rd cell + x cells = your subtotals
               End With

               .AutoFilter                                      'in case you want to reset the filter

 

[winstela]

Thank you for your reply

I am getting a Compile error: Method or data member not found on line below

I used "A" as this is one of my products

.Value = "Myproduct"

any thoughts?

Thanks

 

[BSALV]

you get that error in that line ".value" ???

Where is your destination, did you change the name of your other sheet ?
With that msgbox, you get an answer.

Set cdest = Sheets("OtherSheet").Range("A" & Rows.Count).End(xlUp).Offset(1)     'next free A-cell in that other sheet
  msgbox cdest.address
             With cdest

 

[winstela]

Thank you for your reply

I am getting a Compile error: Method or data member not found on line below

I used "A" as this is one of my products

.Value = "Myproduct"

any thoughts?

Thanks

Hi BSALV,

Apologies it has taken me so long to reply

I have got the code working but it is still not giving me what I was hoping for

Rather than specifying what "Myproduct" is I want to do a loop for all the products in column 3 apply the filter (with Startdate and EndDate) and then take the csubtotals range for each product so I end up, with the destination sheet showing each csubtotals for each product.

I dont really need the StartDate & EndDate - if the macro could filter on last month by using a dynamic filter

I have been trying all week to figure it out without success, can you help further please?

Thanks
Winstela

 

[winstela]

Hi BSALV,

Apologies it has taken me so long to reply

I have got the code working but it is still not giving me what I was hoping for

Rather than specifying what "Myproduct" is I want to do a loop for all the products in column 3 apply the filter (with Startdate and EndDate) and then take the csubtotals range for each product so I end up, with the destination sheet showing each csubtotals for each product.

I dont really need the StartDate & EndDate - if the macro could filter on last month by using a dynamic filter

I have been trying all week to figure it out without success, can you help further please?

Thanks
Winstela

Hi

I have managed to get something working but not as I wanted, below code filters dynamic date (=LastMonth) in column 2 and them calls another macro which is filtering on the product column then it will copy the range csubtotals to another sheet. I created a button to run the macro
The problem I am seeing is
1. I have to keep running the code for each value in product (clicking on the button)
2. Once all the products have been filtered, its starts again ( this is because I dont know when I have reached the last product and I keep clicking the button)
3. If there is no data for the product ie in the (LastMonth) it shows no data, so I end up copying a line that has no data.

I want to be able to filter on LastMonth in column 2 (the macro does this)
Then filter on each unique product in column 3 automatically and copies my csubtotals range to another worksheet
Then stops when all the products in LastMonth have been copied.
Below is the code that I am having problems with, to get to work as needed

Option Explicit
Dim FltDic As Object
Sub PasteSum()
   Dim Cl As Range
   Static i As Long
  ' Dim i As Long
  
  
      Dim cSubTotals As Range
Dim wksOutput As Worksheet
Dim wks As Worksheet
Dim DestLastRow As Long
Dim LastRow As Long
  
   Set wks = Workbooks("Filter.xlsm").Worksheets("Data")
        LastRow = wks.Cells(Rows.Count, 5).End(xlUp).Row
   Set wksOutput = Workbooks("Filter.xlsm").Worksheets("Monthly")
       DestLastRow = wksOutput.Cells(wksOutput.Rows.Count, "D").End(xlUp).Offset(1).Row
    
   If FltDic Is Nothing Then
      Set FltDic = CreateObject("scripting.dictionary")
      For Each Cl In Range("C5", Range("C" & Rows.Count).End(xlUp))
         FltDic.Item(Cl.Value) = Empty
      Next Cl
   End If
   If i = FltDic.Count Then i = 0
   wks.Range("A4:z" & LastRow).AutoFilter Field:=3, Criteria1:=FltDic.Keys()(i), Operator:=xlFilterValues
  
 
    Set cSubTotals = wks.Range("B1:Z1")
    
    wksOutput.Range("b" & DestLastRow).Resize(, cSubTotals.Columns.Count).Value = cSubTotals.Value
      i = i + 1
End Sub

Below is the code I am using for the date filter LastMonth it calls the above macro at the end.

Sub AutoFilter_Dates_in_Period_Examples123()
'Examples for filtering columns for DATES IN PERIOD
'Date filters presets found in the Date Filters sub menu
 
Dim lo As ListObject
Dim iCol As Long


  'Set reference to the first Table on the sheet
  Set lo = Sheet2.ListObjects(1)
 
  'Set filter field
  iCol = lo.ListColumns("Day").Index
 
 
  'Clear Filters
  lo.AutoFilter.ShowAllData
 
  'Operator:=xlFilterDynamic
  'Criteria1:= one of the following enumerations
 
      
  With lo.Range
    
    'All dates in Last month
    .AutoFilter Field:=iCol, _
                Operator:=xlFilterDynamic, _
                Criteria1:=xlFilterThisMonth
                
 
  End With
Call PasteSum
End Sub

 

[winstela]

Hi

I have managed to get something working but not as I wanted, below code filters dynamic date (=LastMonth) in column 2 and them calls another macro which is filtering on the product column then it will copy the range csubtotals to another sheet. I created a button to run the macro
The problem I am seeing is
1. I have to keep running the code for each value in product (clicking on the button)
2. Once all the products have been filtered, its starts again ( this is because I dont know when I have reached the last product and I keep clicking the button)
3. If there is no data for the product ie in the (LastMonth) it shows no data, so I end up copying a line that has no data.

I want to be able to filter on LastMonth in column 2 (the macro does this)
Then filter on each unique product in column 3 automatically and copies my csubtotals range to another worksheet
Then stops when all the products in LastMonth have been copied.
Below is the code that I am having problems with, to get to work as needed

Option Explicit
Dim FltDic As Object
Sub PasteSum()
   Dim Cl As Range
   Static i As Long
  ' Dim i As Long
 
 
      Dim cSubTotals As Range
Dim wksOutput As Worksheet
Dim wks As Worksheet
Dim DestLastRow As Long
Dim LastRow As Long
 
   Set wks = Workbooks("Filter.xlsm").Worksheets("Data")
        LastRow = wks.Cells(Rows.Count, 5).End(xlUp).Row
   Set wksOutput = Workbooks("Filter.xlsm").Worksheets("Monthly")
       DestLastRow = wksOutput.Cells(wksOutput.Rows.Count, "D").End(xlUp).Offset(1).Row
   
   If FltDic Is Nothing Then
      Set FltDic = CreateObject("scripting.dictionary")
      For Each Cl In Range("C5", Range("C" & Rows.Count).End(xlUp))
         FltDic.Item(Cl.Value) = Empty
      Next Cl
   End If
   If i = FltDic.Count Then i = 0
   wks.Range("A4:z" & LastRow).AutoFilter Field:=3, Criteria1:=FltDic.Keys()(i), Operator:=xlFilterValues
 
 
    Set cSubTotals = wks.Range("B1:Z1")
   
    wksOutput.Range("b" & DestLastRow).Resize(, cSubTotals.Columns.Count).Value = cSubTotals.Value
      i = i + 1
End Sub

Below is the code I am using for the date filter LastMonth it calls the above macro at the end.

Sub AutoFilter_Dates_in_Period_Examples123()
'Examples for filtering columns for DATES IN PERIOD
'Date filters presets found in the Date Filters sub menu
 
Dim lo As ListObject
Dim iCol As Long


  'Set reference to the first Table on the sheet
  Set lo = Sheet2.ListObjects(1)
 
  'Set filter field
  iCol = lo.ListColumns("Day").Index
 
 
  'Clear Filters
  lo.AutoFilter.ShowAllData
 
  'Operator:=xlFilterDynamic
  'Criteria1:= one of the following enumerations
 
     
  With lo.Range
   
    'All dates in Last month
    .AutoFilter Field:=iCol, _
                Operator:=xlFilterDynamic, _
                Criteria1:=xlFilterThisMonth
               
 
  End With
Call PasteSum
End Sub

Finally I have something that works for me, I had to change the code that gets the dict keys to one that was not static, and to combat the rows that are being copied to the destination sheet I have added code to remove those rows based on if the cell is blank.
I am a happy lady

 

[winstela]

Here is my code should anyone be interested

Sub DictionaryGroupData(rngInput As Range, keyColIndex As Long, blHeaders As Boolean)
    'Must add reference to Tools > References > Microsoft Scripting Runtime
    Dim i As Long
    Dim rngCell As Range, rng As Range, rngTemp As Range
    Dim dict As Scripting.Dictionary
    Dim strVal As String
    Dim varOrigItems As Variant, varUniqueItems As Variant, varKey As Variant, _
        varItem As Variant
    Dim lr As Long
    Dim FilterRange As Range
    Dim cSubTotals As Range
    
    
    Application.ScreenUpdating = False
    'Call AutoFilter_Dates_in_Period_Examples123
    Set rng = rngInput.Columns(keyColIndex)
    Set dict = New Scripting.Dictionary
    
    ' set compare mode to text
    dict.CompareMode = TextCompare
    
    ' offset by one row if range has headers
    If blHeaders Then
        With rngInput
            Set rngInput = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
        End With
    End If
    
    ' add keys and values to dictionary
    With rngInput
        For Each rngCell In rngInput.Columns(keyColIndex).Cells
            i = i + 1
            strVal = rngCell.Text
            
            ' add new key and item range
            If Not dict.Exists(strVal) Then
                dict.Add strVal, .Rows(i)
                
            ' merge item ranges of existing key
            Else
                Set rngTemp = Union(.Rows(i), dict(strVal))
                dict.Remove strVal ' simply updating the item in a loop will cause a run-time error!
                dict.Add strVal, rngTemp
            End If
        Next rngCell
    End With
    
    For Each varKey In dict.Keys
        ' *********************************************
        '
     Set wks = Workbooks("Filter.xlsm").Worksheets("Data")
     LastRow = wks.Cells(Rows.Count, 5).End(xlUp).Row
    
    
     Set wksOutput = Workbooks("Filter.xlsm").Worksheets("Monthly")
       DestLastRow = wksOutput.Cells(wksOutput.Rows.Count, "D").End(xlUp).Offset(1).Row
     On Error Resume Next
     wks.Range("A4:z" & LastRow).AutoFilter field:=3, Criteria1:=varKey, Operator:=xlFilterValues
       Set cSubTotals = wks.Range("D1:Z1")
      
    wksOutput.Range("b" & DestLastRow) = wks.Range("B5:B" & LastRow).SpecialCells(xlCellTypeVisible).Cells(1).Value
    wksOutput.Range("b" & DestLastRow).Offset(, 1).Value = (varKey)
    wksOutput.Range("b" & DestLastRow).Offset(, 2).Resize(, cSubTotals.Columns.Count).Value = cSubTotals.Value
    ' *********************************************
        'Debug.Print varKey & ": " & dict.Item(varKey).Address ' remove in production
    Next varKey
    ' *********************************************
    ' or add code here for specific key actions
    ' dict("A").Select
    ' *********************************************
    
    Application.ScreenUpdating = True

End Sub
'invoke the procedure the following way:
Sub CallDataGrouper()
Dim lr As Long
Dim ws As Worksheet
Set ws = Sheet2
lr = ws.Cells(Rows.Count, 5).End(xlUp).Row

Call AutoFilter_Dates_in_Period_Examples123 'filters day column by LastMonth'
Call DictionaryGroupData(Range("A4:z" & lr), 3, True)
Call DeleteRowsWithBlankCellsInB 'Deletes cells with blanks in column B '
Call UnFilter ' Clears selection in filters'
End Sub