Question

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个选项卡中。

任何提示或想法都可以帮助您。谢谢，

Answer 1

尝试将.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

VBA复制数据出错

1 个答案: