Sub CopyTMR()
Dim sheet_number As Integer
Dim counter As Integer
Dim last_row As Integer
Dim wb As Workbook
Dim tmr As Worksheet
Set wb = ActiveWorkbook
Set tmr = wb.Sheets("Team Member Rules")
' Counting the sheets number
sheet_number = Worksheets.Count
'MsgBox sheet_number
'MsgBox "Before you continue, make sure all sheets has the Header at the first row"
' Clearing existing TMR in the sheet4
tmr.Select
ActiveSheet.UsedRange.Offset(1, 0).Clear
' If there more than 4 sheets, then we copy from the 5th until the last tab to 4th (TMR)
If sheet_number > 4 Then
' Loop to copy any sheet after TMR tab to the TMR Tab
For counter = 5 To sheet_number
' Selecting the corresponding tab to copy
Worksheets(counter).Select ActiveSheet.Range("A1:A1").Select
ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
' The Header is not copy
Selection.Offset(1, 0).Copy
' Moving back to TMR Tab to paste data
tmr.Select
' Selecting the last row of TMR bab before pasting data after it
last_row = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
ActiveSheet.Range("A" & last_row + 1).Select
ActiveSheet.Paste
Next
End If
' Best fit
tmr.Select
ActiveSheet.UsedRange.Select
Selection.AutoFilter
Application.CutCopyMode = False
Selection.ColumnWidth = 100
Selection.Columns.AutoFit
Selection.Rows.AutoFit
ActiveSheet.Range("A2").Select
ActiveWindow.FreezePanes = True End Sub
大家好! 我上面的代码有问题。 由于某种原因,它可以正常工作一会儿,然后以“运行时错误1004”停止。
我要执行的操作是在第4个选项卡之后“复制所有选项卡的内容而没有标题”并将其粘贴到第4个选项卡中。
任何提示或想法都可以帮助您。 谢谢,
答案 0 :(得分:0)
尝试将.CurrentRegion与.Offset结合使用。变体数组将有助于完全避免剪贴板。
Sub CopyTMR()
di w as long, arr as variant
for w = 5 to worksheets.count
with worksheets(w)
arr = .cells(1,1).currentregion.offset(1,0).value
end with
with worksheets(4)
.cells(.rows.count,"B").end(xlup).offset(1, -1).resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
next w
end sub