Excel VBA：检查工作表是否存在；复制/粘贴到新工作表 - 粘贴失败

Question

我有一个宏，可以将选择从一个工作表 (Sheet1) 复制/粘贴到另一个工作表 (Notes)。它运作良好。现在我想首先检查该工作表是否存在。如果它不存在，我想创建它，然后继续复制/粘贴选择。

当“Notes”工作表存在时，复制/粘贴工作正常。 如果工作表不存在，则会创建它，但粘贴操作不起作用。我没有收到任何错误。我必须重新运行宏，然后粘贴才能工作（因为已经创建了工作表）。关于我错过了什么的任何想法？

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

Answer 1

当您执行 添加 时，活动表将成为新的工作表，而您之前的 选择 将丢失............您必须在添加之前“记住”它：

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

注意引用 RtoCopy 的三行。

Answer 2

您的代码中有 On Error Resume Next。第一次通过它继续快乐的方式。第二次通过错误检查触发新选项卡的创建。

On Error Resume Next 不好。不要使用它。

有关解决您的问题的更多信息，请参阅此问题How to check whether certain sheets exist or not in Excel-VBA?

Answer 3

您应该首先激活并选择要复制的工作表和范围。这行得通。

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

Answer 4

我建议使用Function 以获得更多可重用性：

1. 又脏又快的方法：

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. 正确但有点慢的方法：

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

现在你只需要像这样使用它：

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