简体   繁体   中英

Excel VBA: Check if worksheet exists; Copy/Paste to new worksheet - Paste fails

I have a macro that copy/pastes a selection from one worksheet ( Sheet1 ), to another worksheet ( Notes ). It works well. Now I want to first check if that worksheet exists. If it does not exist, I want to create it, then continue with the copy/pasting the selection.

When the " Notes " worksheet exists, the copy/paste works fine. If the worksheet does not exist, it creates it, but the paste operation doesn't work. I don't get any errors. I have to rerun the macro and then the paste works (since the worksheet has already been created). Any ideas on what I missed?

Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"

'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
    GoTo CopyPasteSelection
Else
    Err.Clear
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If

'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

When you do the Add, the activesheet becomes the new worksheet and your previous Selection is lost...............you must "remember" it before the Add :

Sub Copy2sheet()
    Application.ScreenUpdating = False
    Dim copySheet As Worksheet
    Dim pasteSheet As Worksheet
    Dim mySheetName As String, mySheetNameTest As String
    mySheetName = "Notes"
    Dim RtoCopy As Range
    Set RtoCopy = Selection

    'create worksheet at end of workbook if it does not exist
    On Error Resume Next
        mySheetNameTest = Worksheets(mySheetName).Name
    If Err.Number = 0 Then
        GoTo CopyPasteSelection
    Else
        Err.Clear
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
    End If

    'copy/paste selection to Notes worksheet
CopyPasteSelection:
    Set copySheet = Worksheets("Sheet1")
    Set pasteSheet = Worksheets("Notes")
    RtoCopy.Copy
    pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Pay attention to the three lines referencing RtoCopy .

You have On Error Resume Next in your code. First time through it goes on its merry way. The second time through the Error check triggers the creation of the new tab.

On Error Resume Next is bad. Don't use it.

See this question for more information on solving your problem How to check whether certain sheets exist or not in Excel-VBA?

You should first activate and select the sheet and range to be copied. This works.

CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")

Worksheets("Sheet1").Activate 'Activete "Sheet1"
Worksheets("Sheet1").Range("A1").Select 'Select the range to be copied
'Then copy selection
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True

I suggest using Function for more re-usability:

  1. A dirty and fast way:

Function isWorksheetValid(wsName As String)
    ON Error Goto ErrHndl
    Dim ws as Worksheet
    Set ws = Sheets(wsName)
    isWorksheetValid = True
    Exit Function
ErrHndl:
    isWorksheetValid = False 
End Function
  1. A correct but a bit slower way:

Function isWorksheetValid(wsName As String)
    ON Error Goto ErrHndl
    Dim ws as Worksheet
    For Each ws in Sheets
        If (UCASE(ws.Name) = UCASE(wsName)) Then
            isWorksheetValid = True
            Exit Function
        End If
    Next
ErrHndl:
    isWorksheetValid = False 
End Function

Now you need just use it like this:

If (isWorksheetValid(mySheetName) Then
    ' Add your code here
End If

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM