Move or Copy sheet not working / Also VBA Run-time error ‘1004’: Copy method of Worksheet class failed

[EC1728]

Good morning everyone. I have recently run into the following problem:

I have searched the forum along with numerous other sites and can't seem to find the solution to my problem. I am currently using Excel 2016 (Microsoft Office Professional Plus).

I have a sheet named 29A-1 and I am attempting to make numerous copies of the same worksheet. I have attempted to right-click on the sheet tab, select Move or Copy, then check the Create a copy box. I have also attempted holding Ctrl then clicking on the tab and dragging it to the end. The sheet and workbook are not protected.

I have also tried the following VBA Code:

Sub CopyActiveSheet()
ActiveSheet.Copy After:=Sheets(Sheets.Count)
End Sub

The VBA code will work one time and then on the second attempt it throws the Run-time error ‘1004’: Copy method of Worksheet class failed. If I reset the code it will work again one time then error again on the second time.

Basically what I end up with is tabs that look like this:

29A-1 29A-1 (2) Sheet3 29A-1 (3) Sheet5

Sheet3 and Sheet5 are completely blank. I am getting similar results when I use the Move or Copy option and clicking Ctrl then dragging the tab. Anyone have any ideas on what the issue might be or how I can fix it.

Thank you and I appreciate any help.

 

[EC1728]

Replace this

   WS.UsedRange.Copy DestWS.Range("A1")

with this

    WS.UsedRange.Copy
    With DestWS.Range("A1")
    .PasteSpecial (xlPasteAll)
    .PasteSpecial (xlPasteColumnWidths)
    .Select
    End With

@rlv01

I had to make one modification to code or I would get a pop up that says - There's already data here. Do you want to replace it?

I made the following change:

WS.UsedRange.Copy
    With Range("A1")
    .PasteSpecial (xlPasteColumnWidths)
    .PasteSpecial xlPasteAll
    .Select
    Application.CutCopyMode = False
    End With

I think this takes care of the column widths first then pastes everything else. Which brings me to the next question. I have tried to find a solution but can't seem to get it right. How do I go about making it paste the same row heights? I guess I should have also thought of that before when thinking about the column widths.

Also, not sure if this is asking too much but I do have some vba code in the worksheet coding that executes when there is a worksheet change. When I was duplicating and coping the sheet the vba sheet code copied over. With the method we are attempting to use the vba code does not copy over. Any ideas?

Again, I really appreciate all the help. Have been trying to figure this out on my own but keep getting stumped.

 

[johnnyL]

@EC1728 You might try adding the following subroutine:

Sub CopyRowHeigths(TargetRange As Range, SourceRange As Range)
'
    Dim CurrentRow As Long
'
    Application.ScreenUpdating = False
'
    With SourceRange
        For CurrentRow = 1 To .Rows.Count
            TargetRange.Rows(CurrentRow).RowHeight = .Rows(CurrentRow).RowHeight
        Next CurrentRow
    End With
'
    Application.ScreenUpdating = True
End Sub

And then add the following after the 'End With" in your last post:

Call CopyRowHeigths(WS.UsedRange, DestWS.Range("A1"))

I think that /\ /\ /\ will send the proper ranges to the subroutine to 'CopyRowHeigths'

 

[rlv01]

@rlv01
....but I do have some vba code in the worksheet coding that executes when there is a worksheet change. When I was duplicating and coping the sheet the vba sheet code copied over

Yeah, that's a pretty significant piece of information. First, before getting into programming the code module, as an experiment I'd recommend going back to your original copy code and try this variation to see if it was the event code in your worksheet that was messing up the copy operation:

Sub CopyActiveSheet()
    Application.EnableEvents = False
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
    Application.EnableEvents = True
End Sub

 

[EC1728]

Yeah, that's a pretty significant piece of information. First, before getting into programming the code module, as an experiment I'd recommend going back to your original copy code and try this variation to see if it was the event code in your worksheet that was messing up the copy operation:

Sub CopyActiveSheet()
    Application.EnableEvents = False
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
    Application.EnableEvents = True
End Sub

This code worked to make one copy then on the second attempt I received the Run-time error again. Highlights this line ActiveSheet.Copy After:=Sheets(Sheets.Count)

 

[rlv01]

This code worked to make one copy then on the second attempt I received the Run-time error again. Highlights this line ActiveSheet.Copy After:=Sheets(Sheets.Count)

Back to the workaround it is.....

''' IMPORTANT: Requires the 'Microsoft Visual Basic for Applications Extensibility 5.3' reference to be enabled.
Sub CopyActiveSheet()
    Dim WB As Workbook, DestWS As Worksheet, WS As Worksheet
    Dim SName As String
    Dim N As Long
    Dim S As String
    
    Set WB = ActiveSheet.Parent
    Set WS = ActiveSheet
    Application.ScreenUpdating = False
    
    'Add new sheet, copy data
    Set DestWS = WB.Worksheets.Add(After:=WB.Sheets(WB.Sheets.Count))
    WS.UsedRange.Copy
    With DestWS.Range("A1")
        .PasteSpecial xlPasteAll
        .PasteSpecial xlPasteColumnWidths
        .Select
    End With
    
    'Copy any code
    With WB.VBProject
        S = ""
        With .VBComponents(WS.CodeName).CodeModule
            If .CountOfLines > 0 Then
                S = .Lines(1, .CountOfLines)
            End If
        End With
        With .VBComponents(DestWS.CodeName).CodeModule
            If .CountOfLines > 0 Then
                .DeleteLines 1, .CountOfLines
            End If
            .AddFromString S
        End With
    End With
    
    'new sheet name code. There may be a more elegant way.
    N = 2
    SName = Trim(Split(WS.Name, "(")(0))
    On Error GoTo NextName
    DestWS.Name = SName & " (" & N & ")"
    Application.ScreenUpdating = True
    Exit Sub
NextName:
N = N + 1 'try the next one
If N > 250 Then Exit Sub    'safety exit in case of unknown problem
Resume
End Sub