Filter and copy Loop fails when using an array

[mordrid]

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

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]

I haven't had a chance to look at your code, but to filter for dates prior to today's date, try...

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

 

[mordrid]

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]

To include blank cells, try...

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

 

[mordrid]

Hi, thanks but this is why I am concerned re date filter

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

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]

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...

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]

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]

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

 

[Domenic]

Thank you for your kind words. I'm really glad I could help.

Cheers!

 

[mordrid]

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.