Running VBA code across multiple sheets issue - excel

Question

I am currently using this code which goes through my worksheet and checks in the range O15:O300 to see if there are any cells that match the current date. If there is then it copies the entire row to worksheet "Today's Actions" then copies the site number (Situated in cell C3) to column AA in "Todays Actions".
I use the below code which works fine for this task for one specific sheet:
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
However, there are multiple sheets that I need to action this code for. So I use the below code to run this across all 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
This issue I'm having is that it seems to work fine but randomly whenever there are a lot of dates that match todays date in range O15:O300, it duplicates some lines up to or slightly exceeding 300 rows (So as an example, if there were 15 rows that 'should' be brought back to "Today's action" 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 but I even edited the range to go to 'last row' and it still brings back the same issue. Any thoughts? I've been trying to solve this for days now. Any help appreciated

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

Answer 3

My process was different from the other responses, so I will still post it. I have also added a way of logging that a row has been logged because otherwise I saw that rows could be duplicated to the "Today's Actions" sheet.
Sub rangecheck(ByVal checkedSheet As Worksheet)
'#PARAM checkedSheet is the sheet to iterate through for like dates.
'Instantiate counter variables
Dim matchRow As Integer
matchRow = 0
Dim pasteRow As Integer
pasteRow = 0
Application.ScreenUpdating = False
For Each cell In checkedSheet.Range("O15:O300")
If cell.Value = Date Then
matchRow = cell.Row
'Checks if the row has been logged already (I use column "A" because I
'have no data in it, but this can be amy column in the row)
If checkedSheet.Cells(matchRow, 1) = "Logged" Then
'Do nothing
Else
'Sets value of "pasteRow" to one lower than the lowest used row in
column "AA"
pasteRow = Sheets("Today's Actions").Cells(Rows.Count,
27).End(xlUp).Row + 1
'Copies the values of the matchRow to the pasteRow
Sheets("Today's Actions").Rows(pasteRow).Value =
checkedSheet.Rows(matchRow).Value
'Copies the value of the Site Number to the paste row column "AA"
Sheets("Today's Actions").Cells(pasteRow, 27).Value =
checkedSheet.Cells(3, 3).Value
'Log that a row has been added to the "Today's Actions" sheet
checkedSheet.Cells(matchRow, 1) = "Logged"
End If
End If
Next
Application.ScreenUpdating = True
End Sub
I have also modifed your sub which calls the copying sub to check if it is trying to copy the "Today's Actions" sheet.
Sub rangecheck_Set()
Dim ws As Worksheet
Dim starting_ws As Worksheet
Set starting_ws = Worksheets("Today's Actions")
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
'Check if the ws to check is "Today's Actions"
If ws.Name = "Today's Actions" Then
'Do Nothing
Else
Call rangecheck(ws)
End If
Next
starting_ws.Activate 'activate the worksheet that was originally active
Application.ScreenUpdating = True
End Sub