Check cells across multiple sheets

Question

This code checks the range O15:O300 of one specific sheet.

If there are any cells that match the current date, it copies the entire row to worksheet "Today's Actions" then copies the site number (cell C3) to column AA in "Todays Actions".

Sub rangecheck()

Application.ScreenUpdating = False

For Each cell In Range("O15:O300")
    If cell.Value = Date Then
        matchRow = cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy
        Sheets("Today's Actions").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        ActiveSheet.Range("C3").Copy
        Sheets("Today's Actions").Range("AA" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End If
Next

Application.ScreenUpdating = True

End Sub

I need to action this task for multiple sheets.

Sub rangecheck_Set()

Dim ws As Worksheet
Dim starting_ws As Worksheet

Set starting_ws = ActiveSheet 

Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
    ws.Activate
    Call rangecheck
Next

starting_ws.Activate 'activate the worksheet that was originally active ("Today's Actions")

Application.ScreenUpdating = True

End Sub

Randomly whenever there are a lot of dates that match today's date in range O15:O300, it duplicates some lines up to or slightly exceeding 300 rows.
As an example, if there were 15 rows that 'should' be brought back to "Today's Actions" tab, it would bring them back but then have a few other rows randomly duplicated down to around row 300.

I get this might be due to the range going down to 300.
I edited the range to go to 'last row' and it brings back the same issue.

Answer 1

Don't use implicit references to worksheets and ranges. It is most likely that this is the reason for your problem.

Also you don't need to select and copy - another source for unforeseeable errors.

Another reason for your error could be that you don't exclude "Today's Actions"-sheet from the copying routine.

I re-wrote your sub that is copying the data:

Sub copyTodaysRows(wsSource As Worksheet, wsTarget As Worksheet)

If wsSource is wsTarget then Exit Sub   'don't run this for the target sheet

Dim c As Range, wsTargetNewRow As Long

For Each c In wsSource.Range("O15:O300")

    If c.Value = Date Then
        With wsTarget
            wsTargetNewRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            c.EntireRow.Copy Destination:=.Range("A" & wsTargetNewRow) 
            .Range("AA" & wsTargetNewRow).Value = wsSource.Range("C3").Value
        End With
    End If
Next



End Sub

It takes the source sheet and the target sheet as input parameters.

You will call it like this within your "outer" routine:

Sub rangecheck_Set()


Application.ScreenUpdating = False

Dim wsSource as worksheet

Dim wsTarget as worksheet
Set wsTarget = Thisworkbook.Worksheets("Today's Actions")

For Each wsSource In ThisWorkbook.Worksheets
   copyTodaysRows wsSource, wsTarget
Next
Application.ScreenUpdating = True

End Sub

Answer 2

Copy Values of Criteria (Dates) Rows From Multiple Worksheets

Option Explicit

Sub RetrieveTodaysActions()
    ' Calls 'RetrieveTodaysActionsCall'.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet
    
    For Each sws In ThisWorkbook.Worksheets
        RetrieveTodaysActionsCall sws
    Next sws

    MsgBox "Today's actions retrieved.", vbInformation

End Sub

Sub RetrieveTodaysActionsCall(ByVal sws As Worksheet)
    
    ' Define constants.
    ' Source
    Const sCriteriaColumnAddress As String = "O15:O300"
    Const sCol1 As String = "A"
    Const sCell2Address As String = "C3"
    ' Destination
    Const dName As String = "Today's Actions"
    Const dCol1 As String = "A"
    Const dCol2 As String = "AA"
    ' Both
    ' Write the criteria date to a variable ('CriteriaDate').
    Dim CriteriaDate As Date: CriteriaDate = Date ' today
    
    ' Exclude the destination worksheet.
    If StrComp(sws.Name, dName, vbTextCompare) = 0 Then Exit Sub
    
    ' Reference the source criteria column range ('scrg').
    Dim scrg As Range: Set scrg = sws.Range(sCriteriaColumnAddress)
    
    ' Check the number of matches, the number of rows to be copied
    ' to the destination worksheet.
    If Application.CountIf(scrg, Date) = 0 Then Exit Sub
    
    ' Reference the range ('surg'), the range from the first cell
    ' in the source column ('sCol1') to the last cell of the used range.
    Dim surg As Range
    With sws.UsedRange
        Set surg = sws.Range(sCol1 & 1, .Cells(.Rows.Count, .Columns.Count))
    End With
    
    ' Reference the source range ('srg').
    Dim srg As Range: Set srg = Intersect(scrg.EntireRow, surg)
    If srg Is Nothing Then Exit Sub
    
    ' Write the number of columns of the source range to a variable (cCount).
    Dim cCount As Long: cCount = srg.Columns.Count
    
    ' Write the criteria column number to a variable ('CriteriaColumn').
    Dim CriteriaColumn As Long: CriteriaColumn = scrg.Column
    
    ' Write the values from the source range to an array ('Data').
    Dim Data() As Variant: Data = srg.Value
        
    Dim sValue As Variant ' Criteria Value in the Current Source Row
    Dim sr As Long ' Current Source Row
    Dim c As Long ' Current Source/Destination Column
    Dim dr As Long ' Current Destination Row
    
    ' Loop through the rows of the array.
    For sr = 1 To UBound(Data, 1)
        ' Write the value in the current row to a variable.
        sValue = Data(sr, CriteriaColumn)
        ' Check if the current value is a date.
        If IsDate(sValue) Then
            ' Check if the current value is equal to the criteria date.
            If sValue = CriteriaDate Then
                dr = dr + 1
                ' Write the values from the source row to the destination row.
                For c = 1 To cCount
                    Data(dr, c) = Data(sr, c)
                Next c
            End If
        End If
    Next sr
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = sws.Parent.Worksheets(dName)
    
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, dCol1).End(xlUp).Offset(1)
    
    ' Reference the destination range ('drg').
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    
    ' Write the values from the array to the destination range.
    drg.Value = Data
    
    ' Reference the destination range 2 ('drg2').
    Dim drg2 As Range: Set drg2 = drg.EntireRow.Columns(dCol2)
    
    ' Write the source cell 2 value to the destination range 2 ('drg2')
    ' (the same value to all cells of the range).
    drg2.Value = sws.Range(sCell2Address).Value
    
End Sub