J'ai donc créé un morceau de code pour copier une feuille existante dans une nouvelle feuille et la nommer, en fonction de certaines options choisies dans la feuille d'origine.

Le problème est que si une feuille nommée "Exemple 1" existe déjà et que la feuille d'origine est invitée à créer une nouvelle feuille et à la nommer "Exemple 1", le programme génère une erreur.

J'ai essayé de contourner ce problème en ajoutant une boucle qui vérifie toutes les feuilles de calcul pour le nom donné, et s'il existe, demande à l'utilisateur s'il doit être supprimé ou non.

Si l'utilisateur souhaite la supprimer, elle est supprimée et une nouvelle version de la feuille est créée avec le même nom. Sinon, le programme se termine.

Cela seul fonctionne très bien, mais si le programme ne trouve PAS une feuille avec le même nom que celle que je crée, alors rien ne se passe.

Le code est comme suit

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

Je me rends compte que rien ne se passe parce que je n'ai pas ajouté de code pour cela, mais toutes mes tentatives jusqu'à présent ont abouti à des erreurs ou ont foiré ce qui fonctionnait auparavant.

C'est ma tentative la plus fonctionnelle à ce jour.

1
Christian Emil Johansen 21 avril 2017 à 17:30

3 réponses

Meilleure réponse

Une variante fonctionnelle du code original, aussi rudimentaire soit-elle.

J'ai eu l'idée de l'utilisateur fbonetti sur cette question 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
0
Community 23 mai 2017 à 11:54

En fait, la manière dont vous avez essayé est la plus difficile. Le moyen le plus simple est l'inverse. Essayez simplement de définir la feuille de calcul comme si elle existait. S'il n'existe pas, une erreur se produira, auquel cas vous le créez.

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

Voici une variante du thème ci-dessus. La fonction SheetExists retournera Vrai ou Faux en réponse à cette question.

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
0
Variatus 21 avril 2017 à 15:13

Juste une structure du code qui a fonctionné pour moi.

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

Sheet_Exists:
0
Vikash Singh 8 mai 2018 à 08:47