Copy a range from sheet 1 and paste to next empty row on next sheets in loop

Question

I'm trying to copy a range on a sheet called "template", go to the next sheet, find the next available row and paste the copied range. Then go up 7 rows, select 7 rows down to hide those rows so only the new 7 rows i've pasted are visible. But I need to exclude the sheet called "template" and one called "timecard" Thank you for your help. All parts work fine but it is not going to the next worksheet, it stays on "template" (sheet i'm copying range from). This is what i have so far:

Sub TimeCardReset()
Dim sh As Worksheet

Sheets("Template").Activate
Range("A3:G9").Select
Selection.Copy
            
For Each sh In ThisWorkbook.Worksheets
        If sh.Name = "TEMPLATE" Then
        ' do nothing
        ElseIf sh.Name = "TimeCard" Then
        ' do nothing
        Else
           Range("A" & Rows.Count).End(xlUp).Select
           ActiveCell.Offset(1, 0).Select
           ActiveSheet.Paste
           ActiveCell.Offset(-7, 0).Select
           '   Select current row through 6 rows and hide those rows
           ActiveCell.Resize(7, 1).EntireRow.Hidden = True
        End If
Next sh
Application.CutCopyMode = False
End Sub

Answer 1

Here is an example (untested) that takes into account some of the items mentioned in the comments above. (it could be refined more, with more understanding of your specific file and use case).

Sub TimeCardReset()
    Dim sh As Worksheet
    Dim sSourceSheet$, sSourceRange$
    Const cTEMPLATE = "TEMPLATE" as string
    Const cTIMECARD = "TimeCard" as string

    sSourceSheet = "Template"
    sSourceRange = "A3:G9"

    Sheets(sSourceSheet).Range(sSourceRange).Copy
            
    For Each sh In ThisWorkbook.Worksheets
        If (not(sh.Name = cTEMPLATE) and not(sh.Name = cTIMECARD)) Then
           Sheets(sh).Range("A" & Rows.Count).End(xlUp).Select
           ActiveCell.Offset(1, 0)..Paste
           ActiveCell.Offset(-7, 0)..Resize(7, 1).EntireRow.Hidden = True
        End If
    Next sh
    Application.CutCopyMode = False
End Sub

I am not sure exactly what in your workbook is driving the decision making behind the line Sheets(sh).Range("A" & Rows.Count).End(xlUp).Select, so have left it to 'select' and then 'active cell'

You will see that for future-proofing I have also moved some of the input items up to variables or constants, you could do the same for the offset and resize values (6, 7, 1, 0, -1) and for the first column (A) of the destination sheet. (these steps are optional).

Is the resize bit critical to what you are trying to achieve, or was it just a non-critical operation that formed part of the recorded macro?

Note: this function will run much quicker if you can perform the operations without Select and ActiveCell, whereby the sheets are all changed by the code without physically navigating to them along the way. This may be relevant if there are many sheets.

Also: consider including all sheets that would be relevant, rather than excluding two you know are not. That way, adding a new sheet sometime later for some other purpose is less likely to break the code.

Answer 2

Copy Range To Several Worksheets

• The 1st Sub will copy only the values, but uses an array to increase efficiency.
• The 2nd Sub will copy the 'whole thing', including values, formulas, formats...
• There is also a 3rd possibility using PasteSpecial, when there are more possibilities of what is to be copied.

The Code

Option Explicit

' If only values are to be copied:
Sub TimeCardReset()
    
    ' Constants (adjust if necessary)
    Const wsName As String = "Template"
    Const CopyRangeAddress As String = "A3:G9"
    Const LastRowColumn As Variant = "A" ' e.g. 1 or "A"
    Dim Exceptions As Variant
    Exceptions = Array("Template", "TimeCard") ' Add more...
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Write values of Copy Range to array (Data).
    Dim Data As Variant
    Data = wb.Worksheets(wsName).Range(CopyRangeAddress).Value
    
    ' Calculate number of rows and columns in array (of Copy Range).
    Dim ubr As Long: ubr = UBound(Data)
    Dim ubc As Long: ubc = UBound(Data, 2)
    
    Dim ws As Worksheet, cel As Range, PasteRange As Range
    ' Loop through all worksheets in workbook.
    For Each ws In ThisWorkbook.Worksheets
        ' Check if name of current worksheet is not contained
        ' in Exceptions array.
        If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
            ' Define first empty cell (cel) in LastRowColumn.
            Set cel = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Offset(1)
            ' Define Paste Range.
            Set PasteRange = cel.Resize(ubr, ubc)
            ' Write values of array to Paste Range.
            PasteRange.Value = Data
            ' Check if hiding is possible.
            If PasteRange.Row > ubr Then
                ' Hide rows of previous Paste Range in current worksheet.
                PasteRange.Offset(-ubr).Rows.EntireRow.Hidden = True
            Else
                ' The following line would be very annoying if many sheets.
                'MsgBox "There isn't enough rows above.", vbExclamation, "Fail"
            End If
        End If
    Next ws

    ' Inform user
    MsgBox "Operation finished successfully.", vbInformation, "Success"

End Sub

' If values, formulas, formats... are to be copied:
Sub TimeCardResetAll()
    
    ' Constants (adjust if necessary)
    Const wsName As String = "Template"
    Const CopyRangeAddress As String = "A3:G9"
    Const LastRowColumn As Variant = "A" ' e.g. 1 or "A"
    Dim Exceptions As Variant
    Exceptions = Array("Template", "TimeCard") ' Add more...
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define Copy Range.
    Dim CopyRange As Range
    Set CopyRange = wb.Worksheets(wsName).Range(CopyRangeAddress)
    
    ' Calculate number of rows and columns of Copy Range.
    Dim ubr As Long: ubr = CopyRange.Rows.Count
    Dim ubc As Long: ubc = CopyRange.Columns.Count
    
    Dim ws As Worksheet, PasteCell As Range
    ' Loop through all worksheets in workbook.
    For Each ws In ThisWorkbook.Worksheets
        ' Check if name of current worksheet is not contained
        ' in Exceptions array.
        If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
            ' Define first empty cell (PasteCell) in LastRowColumn.
            Set PasteCell = _
              ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Offset(1)
            ' Copy from Copy Range to Paste Cell (formulas, formats... incl.).
            CopyRange.Copy PasteCell
            ' Check if hiding is possible.
            If PasteCell.Row > ubr Then
                ' Hide rows of previous Paste Range in current worksheet.
                PasteCell.Resize(ubr).Offset(-ubr).EntireRow.Hidden = True
            Else
                ' The following line would be very annoying if many sheets.
                'MsgBox "There isn't enough rows above.", vbExclamation, "Fail"
            End If
        'Else ' Current worksheet name is contained in Exceptions array.
        End If
    Next ws

    ' Inform user
    MsgBox "Operation finished successfully.", vbInformation, "Success"

End Sub

Answer 3

To simplify your code; use the With Statement, to get rid of Select, Activate, and ActiveSheet. If you only want to copy the values to the other worksheet, you don't need to use an Array or excessive Variables to accomplish your task, you can just set the destination range equal to the source range, which is faster because it bypasses the clipboard entirely. The lRow variable is used as a reference point for both lines of code.

Dim ws As Worksheet, lRow As Long

    For Each ws In ThisWorkbook.Sheets 'loop through all the worksheets
        If ws.Name <> "Template" And ws.Name <> "TimeCard" Then 'skip these worksheets
            
            With ws 'to avoid using Select, ActiveCell, and ActiveSheet

                lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Set the last row for the current ws
              
                'Added - This line will copy both formulas and values
                ThisWorkbook.Sheets("Template").Range("A3:G9").Copy Destination:=.Cells(lRow, "A").Offset(1)
                
                'Deleted - use lRow, Offset, and Resize to set the range on destination sheet to match the range on the "Template" worksheet
                'Deleted - .Cells(lRow, "A").Offset(1).Resize(7, 7).Value = ThisWorkbook.Sheets("Template").Range("A3:G9").Value
                
                'Use lRow, Offset and Resize to to select the rows you want to hide
                .Cells(lRow, "A").Offset(-6).Resize(7).EntireRow.Hidden = True
            End With
        End If
    Next ws