Question

因此，我根据原始工作表中选择的一些选项，制作了一段代码，将现有工作表复制到新工作表中并命名。

问题是如果一张名为＆＃34;示例1＆＃34;已存在，并要求原始工作表创建一个新工作表并命名为＆＃34;示例1＆＃34;那么程序就会出错。

我试图通过添加一个循环来解决这个问题，该循环检查给定名称的所有工作表，如果存在则询问用户是否应该删除它。

如果用户想要删除它，则会将其删除，并使用相同的名称创建新版本的工作表。如果没有，则程序结束。

仅此一项工作正常且花花公子，但如果程序找不到与我创建的名称相同的工作表，则没有任何反应。

代码如下

Sub TestForArk()
'Modul til at kopiere Indleveringsplanen som den er, og gøre det nye ark uafhængigt af ændringer i Indleveringsplanen

Dim wb As Workbook
Dim ws As Worksheet

Set wb = ActiveWorkbook

Sheets("Indleveringsplan").Unprotect
'Låser op for indleveringsplanen

    For Each ws In wb.Worksheets
        If ws.Name = "Indleveringsplan (2)" Then
            Application.DisplayAlerts = False
            Sheets("Indleveringsplan (2)").Delete
            Application.DisplayAlerts = True
        End If
    Next

    Sheets("Indleveringsplan").Copy Before:=Sheets(2)
    'Kopierer indleveringsplanen for at få den rette opsætning

    For Each ws In wb.Worksheets
        If ws.Name = ("Indleveringsplan " & Range("L3")) Then
            If MsgBox("Der findes allerede et ark for det valgte produkt, ønsker du at slette det gamle ark og oprette et nyt?", _
            vbYesNo, "Ark med samme navn fundet") = vbYes Then
                Application.DisplayAlerts = False
                Sheets("Indleveringsplan " & Range("L3")).Delete
                Application.DisplayAlerts = True
                Module1.Kopier_Ark
            Else
                Application.DisplayAlerts = False
                Sheets("Indleveringsplan (2)").Delete
                Application.DisplayAlerts = True
                MsgBox "Arket blev ikke oprettet", Title:="Handling Annuleret"
            End If
        End If
        Next
    Sheets("Indleveringsplan").Protect
    'Låser indleveringplanen igen
    End Sub

我意识到没有任何事情发生，因为我没有为此添加任何代码，但到目前为止我的所有尝试都导致了错误或搞砸了之前的工作。

这是我迄今为止最具功能性的尝试。

Answer 1

实际上，你尝试的方式很难。另一种方法是简单的方法。只是尝试将工作表设置为存在。如果它不存在，则会发生错误，在这种情况下您将创建它。

Private Sub ActivateWorksheet()

    Dim Wb As Workbook
    Dim Ws As Worksheet

    Set Wb = ThisWorkbook
    On Error Resume Next
    Set Ws = Wb.Worksheets("Example1")
    If Err Then
        Set Ws = Wb.Worksheets.Add(After:=Wb.Sheets(Wb.Sheets.Count))
        Ws.Name = "Example1"
    End If
    On Error GoTo 0
End Sub

以下是上述主题的变体。函数SheetExists将在回答该问题时返回True或False。

Private Sub TestSheetExists()
    Debug.Print SheetExists("Example1")
End Sub

Private Function SheetExists(WsName As String) As Boolean

    Dim Ws As Worksheet

    On Error Resume Next
    Set Ws = Worksheets(WsName)
    SheetExists = Not CBool(Err)
    Err.Clear
End Function

Answer 2

原始代码的工作变体，粗略可能。

从用户fbonetti那里得到了关于这个问题的想法 https://stackoverflow.com/a/15668661/7780010

Sub TestForArk()
'Modul til at kopiere Indleveringsplanen som den er, og gøre det nye ark uafhængigt af ændringer i Indleveringsplanen

Dim wb As Workbook
Dim ws As Worksheet
Dim exists As Boolean

Set wb = ActiveWorkbook
Sheets("Indleveringsplan").Unprotect
'Låser op for indleveringsplanen

    For Each ws In wb.Worksheets
        If ws.Name = "Indleveringsplan (2)" Then
            Application.DisplayAlerts = False
            Sheets("Indleveringsplan (2)").Delete
            Application.DisplayAlerts = True
        End If
    Next

    Sheets("Indleveringsplan").Copy Before:=Sheets(2)
    'Kopierer indleveringsplanen for at få den rette opsætning

    For Each ws In wb.Worksheets
        If ws.Name = ("Indleveringsplan " & Range("L3")) Then
            exists = True
        End If
    Next

    If exists Then
        If MsgBox("Der findes allerede et ark for det valgte produkt, ønsker du at slette det gamle ark og oprette et nyt?", _
        vbYesNo, "Ark med samme navn fundet") = vbYes Then
            Application.DisplayAlerts = False
            Sheets("Indleveringsplan " & Range("L3")).Delete
            Application.DisplayAlerts = True
            Module1.Kopier_Ark
        Else
            Application.DisplayAlerts = False
            Sheets("Indleveringsplan (2)").Delete
            Application.DisplayAlerts = True
            Sheets("Indleveringsplan").Activate
            MsgBox "Arket blev ikke oprettet", Title:="Handling Annuleret"
        End If
    Else
        Module1.Kopier_Ark
    End If

Sheets("Indleveringsplan").Protect
'Låser indleveringplanen igen

End Sub

Answer 3

只是一个适合我的代码结构。

On Error GoTo Sheet_add:
Set wSheet = NewWorkbook.Sheets(NewSheetname)
GoTo Sheet_Exists
Sheet_add:
    NewWorkbook.Activate
    Sheets.Add
    ActiveSheet.Name = NewSheetname

Sheet_Exists:

检查具有给定名称的工作表并提示用户删除它

3 个答案: