Running VBA code across multiple sheets issue-CodePudding

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

CodePudding user response：

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

CodePudding user response：

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

CodePudding user response：

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