从 sheet 1 复制范围并粘贴到循环中下一个 sheet 的下一个空行
Copy a range from sheet 1 and paste to next empty row on next sheets in loop
我正在尝试在名为“模板”的 sheet 上复制一个范围，转到下一个 sheet，找到下一个可用行并粘贴复制的范围。然后向上 7 行，select 向下 7 行以隐藏这些行，因此只有我粘贴的新 7 行可见。但我需要排除 sheet 称为“模板”和一个称为“时间卡” 谢谢你的帮助。所有部分都工作正常，但它不会进入下一个工作sheet，它停留在“模板”上（sheet 我正在从中复制范围）。这是我目前所拥有的：
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
这是一个示例（未经测试），其中考虑了上述评论中提到的一些项目。 （随着对您的特定文件和用例的更多了解，它可以进一步完善）。
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
我不确定你的工作簿中到底是什么在推动 Sheets(sh).Range("A" & Rows.Count).End(xlUp).Select 行后面的决策，所以把它留给 'select' 然后 'active cell'
您会看到，对于 future-proofing，我还将一些输入项移到了变量或常量上，您可以对偏移量和调整大小值 (6, 7, 1, 0, -1) 和目的地的第一列 (A) sheet。 （这些步骤是可选的）。
调整大小位是否对您要实现的目标至关重要，或者它只是构成录制宏的一部分的 non-critical 操作？
注意：如果您可以在没有 Select 和 ActiveCell 的情况下执行操作，此功能将 运行 快得多，其中 sheet 全部由代码更改而无需物理导航到一路上的他们。如果有很多 sheet，这可能是相关的。
另外：考虑包括所有相关的 sheet，而不是排除两个你知道不相关的。这样，稍后为其他目的添加新的 sheet 不太可能破坏代码。
将范围复制到多个工作表
- 第一个 Sub 将只复制值，但使用数组来提高效率。
- 2nd Sub 将 copy 'whole thing'，包括值、公式、格式...
- 还有第三种可能性，使用 PasteSpecial, when there are more possibilities 要复制的内容。
代码
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
简化您的代码；使用 With 语句，去掉 Select、Activate 和 ActiveSheet。如果您只想将值复制到另一个工作表，则不需要使用数组或过多的变量来完成您的任务，您只需将目标范围设置为等于源范围即可，这样速度更快，因为它绕过了完全剪贴板。 lRow 变量用作两行代码的参考点。
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
我正在尝试在名为“模板”的 sheet 上复制一个范围，转到下一个 sheet，找到下一个可用行并粘贴复制的范围。然后向上 7 行，select 向下 7 行以隐藏这些行，因此只有我粘贴的新 7 行可见。但我需要排除 sheet 称为“模板”和一个称为“时间卡” 谢谢你的帮助。所有部分都工作正常，但它不会进入下一个工作sheet，它停留在“模板”上（sheet 我正在从中复制范围）。这是我目前所拥有的：
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
这是一个示例（未经测试），其中考虑了上述评论中提到的一些项目。 （随着对您的特定文件和用例的更多了解，它可以进一步完善）。
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
我不确定你的工作簿中到底是什么在推动 Sheets(sh).Range("A" & Rows.Count).End(xlUp).Select 行后面的决策，所以把它留给 'select' 然后 'active cell'
您会看到，对于 future-proofing，我还将一些输入项移到了变量或常量上，您可以对偏移量和调整大小值 (6, 7, 1, 0, -1) 和目的地的第一列 (A) sheet。 （这些步骤是可选的）。
调整大小位是否对您要实现的目标至关重要，或者它只是构成录制宏的一部分的 non-critical 操作？
注意：如果您可以在没有 Select 和 ActiveCell 的情况下执行操作，此功能将 运行 快得多，其中 sheet 全部由代码更改而无需物理导航到一路上的他们。如果有很多 sheet，这可能是相关的。
另外：考虑包括所有相关的 sheet，而不是排除两个你知道不相关的。这样，稍后为其他目的添加新的 sheet 不太可能破坏代码。
将范围复制到多个工作表
- 第一个 Sub 将只复制值，但使用数组来提高效率。
- 2nd Sub 将 copy 'whole thing'，包括值、公式、格式...
- 还有第三种可能性，使用 PasteSpecial, when there are more possibilities 要复制的内容。
代码
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
简化您的代码；使用 With 语句，去掉 Select、Activate 和 ActiveSheet。如果您只想将值复制到另一个工作表，则不需要使用数组或过多的变量来完成您的任务，您只需将目标范围设置为等于源范围即可，这样速度更快，因为它绕过了完全剪贴板。 lRow 变量用作两行代码的参考点。
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