Filter and copy Loop fails when using an array

mordrid

Board Regular
Joined
Jul 22, 2005
Messages
219
Hi I have been working on the following code, basically it should filter against two columns across multiple worksheets and dump the results into anther worksheet. The issue that I have is it only appears to post a single row off the final sheet in the Array and I can not understand what is wrong. Any help would be appreciated

VBA Code:
Sub OverdueUpdate()

Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
    Dim lr As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Clears exiting content
    Worksheets("Overdue Items").Range("B8:F29").ClearContents

    Set DestSh = ActiveWorkbook.Worksheets("Overdue Items")

    'Looks through the sheets named and copies data to overdue
  For Each sh In ActiveWorkbook.Sheets(Array("Due Diligence", "Pre-Filing", "Product Development", "CAPM", "Operations"))
               
            'Find the last rows with data
            Last = LastRow(DestSh)
            Last2 = LastRow(sh)
           
            'Filter
            With sh.Range("B5:F" & Last2)
            .AutoFilter Field:=1, Criteria1:="<100%"
            .AutoFilter Field:=3, Criteria1:="<FilterToday"
           
            End With

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("B5:F" & Last2 & lr).SpecialCells(xlCellTypeVisible)
           
            With sh.Range("B5:F" & Last2)
            .AutoFilter Field:=1
            .AutoFilter Field:=3
            End With
           
              With CopyRng
                 DestSh.Cells(Last + 1, "B").Resize(.Rows.Count, _
                .Columns.Count).Value = .Value
             End With
            
    Next

End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("b8"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,502
I haven't had a chance to look at your code, but to filter for dates prior to today's date, try...

VBA Code:
.AutoFilter Field:=3, Criteria1:="<" & Date
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

mordrid

Board Regular
Joined
Jul 22, 2005
Messages
219
Thank You, I really appreciate you spending some time on this helping me as it was driving me crazy yesterday, however still does not appear to filter correctly for example if I have the first col blank and the date one populated it should filter as the date is there, however it does not filter until I put a value in first col. If I go to the sheet and do a manual filter for less than 03/25/2021 then it picks up date ones even if col 1 is blank which is why I dont think it is working in the VBA
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,502
To include blank cells, try...

VBA Code:
.AutoFilter Field:=1, Criteria1:="=", Operator:=xlOr, Criteria2:="<100%"
 

mordrid

Board Regular
Joined
Jul 22, 2005
Messages
219
Hi, thanks but this is why I am concerned re date filter
1616781272170.png
this is dummy data pre running macro and as you can see top one is past todays date so should not appear on filtered list as its looking for dates earlier than today. Here is the filtered result
1616780875506.png
and as you can see the top row came across, however the rows with a date 01/05/2021 and 06/06/2021 did not
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,502

ADVERTISEMENT

I have made a number of changes to your macro. You may need to make some adjustments, depending on your actual data. Here are the main changes that I have made...

1) For each source worksheet, any pre-existing filters are cleared prior to filtering the data.

2) ScreenUpdating and EnableEvents are set to True at the end of the code.

3) For LastRow(...), the starting cell has been changed to A1, since the search occurs in reverse.

Here's your amended code...

VBA Code:
Sub OverdueUpdate()

    Dim DestSh As Worksheet
    Dim sh As Worksheet
    Dim CopyRng As Range
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    Set DestSh = ActiveWorkbook.Worksheets("Overdue Items")
   
    'Clears exiting content
    DestSh.Range("B8:F" & LastRow(DestSh) + 1).ClearContents
   
    'Looks through the sheets named and copies data to overdue
    For Each sh In ActiveWorkbook.Sheets(Array("Due Diligence", "Pre-Filing", "Product Development", "CAPM", "Operations"))

             
         'Filter
         With sh
             If .FilterMode Then .ShowAllData 'clear any existing filters
             With .Range("B5:F" & LastRow(sh))
                 .AutoFilter Field:=1, Criteria1:="", Operator:=xlOr, Criteria2:="<100%"
                 .AutoFilter Field:=3, Criteria1:="<" & Date
                 On Error Resume Next
                 Set CopyRng = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                 On Error GoTo 0
                 If Not CopyRng Is Nothing Then
                    CopyRng.Copy
                    With DestSh
                        .Activate
                        With .Cells(LastRow(DestSh) + 1, "B")
                            .PasteSpecial xlPasteValues
                            .PasteSpecial xlPasteValuesAndNumberFormats
                        End With
                        .Cells(1).Select
                    End With
                    Application.CutCopyMode = xlCopy
                    Set CopyRng = Nothing
                 End If
                 .AutoFilter
             End With
         End With
    Next
   
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
   
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Does this help?
 

mordrid

Board Regular
Joined
Jul 22, 2005
Messages
219
Hi Dominic, thank you for continuing to look at my issue, the code now does only pick up the right dates, however, it is still only pasting the data from the operations sheet (last one in the array) and nothing from the others even though I do have dummy data on them which should copy across
Rgds
Richard
 

mordrid

Board Regular
Joined
Jul 22, 2005
Messages
219

ADVERTISEMENT

Hi Dominic, ignore my last post, looks like that was my fault. Having fixed the dummy data it all appears to work fine

Thank you so much for all you have done I really appreciate it, you are truly a star in these dark times
 

mordrid

Board Regular
Joined
Jul 22, 2005
Messages
219
Hi, Dominic hope you dont mind asking but you were so helpful getting my VBA working, however I am stumped and thought you maybe able / willing to help.

The VBA works fine when I have test data in the file, however when I put actual data in it does not filter or copy data. Can you take a look at the two files and see why it is not working, clearly I would rather not post the data file here so if poss can I have an address to send it to.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,750
Messages
5,638,133
Members
417,010
Latest member
jnuss03

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top