Verifier si une feuille existe

Cedrim69

Cedrim69

XLDnaute Nouveau
Bonjour,

J'ai trouver une fonction sur le forum pour verifier si une feuille existe dans un classeur.
Avec ma macro, je créé un nouveau classeur et copie dans celui ci une feuille de mon "gabarit"
je souhaite supprimé toutes les feuilles du nouveau classeur créé pour ne laisser que celle que j'ai copié.
Mais je ne reussi pas à mettre en oeuvre la fonction :

VB: 
Function IsWorksheet(strName As String) As Boolean
   Dim objWorksheet As Worksheet
   IsWorksheet = False
   For Each objWorksheet In ActiveWorksheets
      If objWorksheet.Name = strName Then
         IsWorksheet = True
      End If
   Next
End Function


Mon code est le suivant :
VB: 
Sub Sauvegarder()
    Dim sRep As String
    Dim NewWb As Workbook, ws As Worksheet

            Set NewWb = Workbooks.Add
            
            'on copie l'onglet gabarit dans le nouveau fichier
            ThisWorkbook.Sheets("Chart").Copy NewWb.Sheets(1)
     
            'Suppression des onglets de base + supression des noms de cellules
            If IsWorksheet(NewWb.Range("Feuil1")) = True Then
                NewWb.Sheets(Array("Feuil1", "Feuil2", "Feuil3")).Delete
            End If
            If IsWorksheet(NewWb.Range("Sheet1")) = True Then
                NewWb.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
            End If

'suite du code 
End Sub


j'ai egalement essayé en modifiant la fonction
VB: 
Function IsWorksheet(strName As String) As Boolean
   Dim objWorksheet As Worksheet
   IsWorksheet = False
   For Each objWorksheet In NewWb.Sheets
      If objWorksheet.Name = strName Then
         IsWorksheet = True
      End If
   Next
End Function


et le code
VB: 
Sub Sauvegarder()
    Dim sRep As String
    Dim NewWb As Workbook, ws As Worksheet

            Set NewWb = Workbooks.Add
            
            'on copie l'onglet gabarit dans le nouveau fichier
            ThisWorkbook.Sheets("Chart").Copy NewWb.Sheets(1)
     
            'Suppression des onglets de base + supression des noms de cellules
            If IsWorksheet("Feuil1") = True Then
                NewWb.Sheets(Array("Feuil1", "Feuil2", "Feuil3")).Delete
            End If
            If IsWorksheet("Sheet1") = True Then
                NewWb.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
            End If

'suite du code 
End Sub


Je cherche à supprimer les feuilles du classeur que je créé que se soit avec Excel en français ou en anglais (maison & boulot)...

Est ce que qqn pourrait m'aider svp ?

Cordialement,

Cédric
 
Trier par date Trier par votes
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Verifier si une feuille existe

Bonjour Cedrim69,

Testez le code:
Code: 
Sub Sauvegarder()
Dim sRep As String, NewSheetName As String
Dim NewWb As Workbook, ws As Worksheet, sh

Set NewWb = Workbooks.Add

'on copie l'onglet gabarit dans le nouveau fichier
ThisWorkbook.Sheets("Chart").Copy NewWb.Sheets(1)
NewSheetName = NewWb.ActiveSheet.Name

'Suppression des onglets de base + supression des noms de cellules
Application.DisplayAlerts = False
For Each sh In NewWb.Sheets
   If sh.Name <> NewSheetName Then sh.Delete
Next sh
Application.DisplayAlerts = True
'suite du code
End Sub
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Verifier si une feuille existe

Bonjour Cedrim69, Bonjour mapomme,
Je n'ai peut-être pas tout compris, mais s'il s'agit de créer un classeur indépendant avec une seule feuille ceci suffit:
VB: 
Sub test()
ThisWorkbook.Sheets("Chart").Copy
End Sub
Cordialement
 
Vote positif 0 Vote négatif
Cedrim69

Cedrim69

XLDnaute Nouveau
Re : Verifier si une feuille existe

J'ai deja écris la macro qui enregistre mes classeurs dans le bon répertoire, je ne sais

VB: 
Sub Sauvegarder()
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'SELECTION DU REPERTOIRE DE SAUVEGARDE
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim sRep As String, NewSheetName As String
Dim NewWb As Workbook, ws As Worksheet, sh

    'répertoire de départ = répertoire du ficher actuel
    sDir = ThisWorkbook.Path
    sRep = ""
    sName = Range("B2")
        
    'répertoire de sauvegarde
    If Chart.Range("B5") = "NO" Then
        sRep = "03 - Non conformités non avérées"
    ElseIf Chart.Range("B5") = "YES" Then
        If Chart.Range("D3") = "" Then
            sRep = "01 - Non coformités réelles non corrigées"
        Else
            sRep = "02 - Non conformités réelles corrigées"
        End If
    Else
        MsgBox "Problem with saving directory : " & vbCr & sRep
        Exit Sub   'Problème
    End If
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'SAUVEGARDE
''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Select Case MsgBox("Chart # : " & sName & vbLf & "will be saved in : " & vbLf & sRep, vbOKCancel + vbInformation)
        
        Case vbOK
            'on crée un nouveau fichier
            Set NewWb = Workbooks.Add
            
            'on copie l'onglet gabarit dans le nouveau fichier
            ThisWorkbook.Sheets("Chart").Copy NewWb.Sheets(1)
            NewSheetName = NewWb.ActiveSheet.Name
            'suppression de l'affichage des messages de confirmation de suppressions
            Application.DisplayAlerts = False
            
            'Suppression des onglets de base
            For Each sh In NewWb.Sheets
                If sh.Name <> NewSheetName Then sh.Delete
            Next sh
            
            'supression des noms de cellules
            NewWb.Names("Catalogues").Delete
            NewWb.Names("DOC_CORRECT").Delete
            NewWb.Names("DOC_NOT_CORRECT").Delete
            
            NewWb.Sheets("Chart").Range("A1:D12").Validation.Delete
           
            'on sauvegarde le fichier créé
            NewWb.SaveAs sDir & "/" & sRep & "/" & sName & ".xlsx", xlOpenXMLWorkbook
            NewWb.Close
                
            'message à l'utilisateur
            MsgBox "Chart # : " & sName & vbCr & "was saved in :" & vbCr & sRep
    
            'affichage des messages de confirmation de suppressions
            Application.DisplayAlerts = True

        Case vbCancel
            MsgBox "Save Canceled"
            Exit Sub
    End Select
    
End Sub


Je ne comprend pas comment utiliser, pourquoi l'utiliser :
VB: 
Sub test()
ThisWorkbook.Sheets("Chart").Copy
End Sub

Est ce que vous avez des commentaires sur mon code ?
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Verifier si une feuille existe

Bonjour Cedrim69,

Efgé (que je salue) a voulu dire que l'instruction ThisWorkbook.Sheets("Chart").Copy crée un nouveau classeur avec pour unique feuille la copie de la feuille "Chart". Le code peut donc se simplifier en remplaçant:
Code: 
        Case vbOK
            'on crée un nouveau fichier
           Set NewWb = Workbooks.Add
            
            'on copie l'onglet gabarit dans le nouveau fichier
           ThisWorkbook.Sheets("Chart").Copy NewWb.Sheets(1)
            NewSheetName = NewWb.ActiveSheet.Name
            'suppression de l'affichage des messages de confirmation de suppressions
           Application.DisplayAlerts = False
            
            'Suppression des onglets de base
           For Each sh In NewWb.Sheets
                If sh.Name <> NewSheetName Then sh.Delete
            Next sh
par
Code: 
        Case vbOK
            'nouveau fichier avec pour unique feuille la copie de "Chart"
            ThisWorkbook.Sheets("Chart").Copy
           Set NewWb =ActiveWorkbook
 
Dernière édition:
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Verifier si une feuille existe

Bonjour Cedrim69, Bonjour mapomme,
Cedrim69 à dit:
Est ce que vous avez des commentaires sur mon code ?
Cliquez pour agrandir...
Peut être comme ça :
VB: 
Sub Sauvegarder()
Dim sRep As String, sName As String, sDir As String, N As Name
Dim F As Worksheet
Set F = ThisWorkbook.Sheets("Chart")
sDir = ThisWorkbook.Path
sName = F.Range("B2")
If F.Range("B5") = "NO" Then
     sRep = "03 - Non conformités non avérées"
 ElseIf F.Range("B5") = "YES" Then
     If F.Range("D3") = "" Then
         sRep = "01 - Non coformités réelles non corrigées"
     Else
         sRep = "02 - Non conformités réelles corrigées"
     End If
 Else
     MsgBox "Problem with saving directory : " & vbCr & sRep
     Exit Sub
End If
Select Case MsgBox("Chart # : " & sName & vbLf & "will be saved in : " & vbLf & _
            sRep, vbOKCancel + vbInformation)
    Case vbOK
        F.Copy
        With ActiveWorkbook
            For Each N In .Names
                N.Delete
            Next N
            .ActiveSheet.Range("A1:D12").Validation.Delete
            .SaveAs sDir & "/" & sRep & "/" & sName & ".xlsx", xlOpenXMLWorkbook
            .Close
        End With
        MsgBox "Chart # : " & sName & vbCr & "was saved in :" & vbCr & sRep
    Case vbCancel
        MsgBox "Save Canceled"
End Select
End Sub

Cordialement
 
Vote positif 0 Vote négatif
Cedrim69

Cedrim69

XLDnaute Nouveau
Re : Verifier si une feuille existe

Merci pour cette simplification. c'est instructif pour moi qui débute.

une question comme ça, je souhaite vérifié que certains champs soit obligatoirement remplis avant l'enregistrement, actuellement j'ai 50 lignes de code comme celle-ci :
VB: 
mMissing = ""
If Chart.Range("B3") = "" Then mMissing = mMissing & "- Name" & vbLf
If mMissing <> "" Then
   MsgBox "Your sheet is missing the following :" & vbLf & mMissing & vbLf & "Save Cancelled" & vbCr & "Please complete informations", vbExclamation, "Avertissement"
   Exit Sub
End If

Voyez-vous un moyen de raccourcir mon code ?
 
Vote positif 0 Vote négatif
Cedrim69

Cedrim69

XLDnaute Nouveau
Re : Verifier si une feuille existe

Bonsoir,

Mon code est le suivant :

VB: 
Sub Sauvegarder()
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'SELECTION DU REPERTOIRE DE SAUVEGARDE
''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim sRep As String, sName As String, sDir As String, N As Name
    Dim F As Worksheet
    Set F = ThisWorkbook.Sheets("Chart")
    sDir = ThisWorkbook.Path
    sName = F.Range("B2")
    If F.Range("B5") = "NO" Then
         sRep = "03 - Non conformités non avérées"
     ElseIf F.Range("B5") = "YES" Then
         If F.Range("D3") = "" Then
             sRep = "01 - Non coformités réelles non corrigées"
         Else
             sRep = "02 - Non conformités réelles corrigées"
         End If
     Else
         MsgBox "Problem with saving directory : " & vbCr & sRep
         Exit Sub
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'VERIFICATION DU REMPLISSAGE
''''''''''''''''''''''''''''''''''''''''''''''''''''''
    mMissing = ""
    mSpare = ""
    If Chart.Range("B5") = "YES" Then
        'INFO GENERAL
            'Infos manquantes
        If Chart.Range("B2") = "" Then mMissing = mMissing & "- ARGUS case number" & vbLf
        If Chart.Range("B3") = "" Then mMissing = mMissing & "- SPE / SPI name" & vbLf
        If Chart.Range("B5") = "" Then mMissing = mMissing & "- Non-conformity doc confirmation" & vbLf
        If Chart.Range("D2") = "" Then mMissing = mMissing & "- ARGUS case date" & vbLf
        If Chart.Range("D3") <> "" And Chart.Range("D4")="" Then mMissing = mMissing & "- Corrector" & vbLf
        'INFO VEHICULE
                'Infos manquantes
        If Chart.Range("B7") = "" Then mMissing = mMissing & "- Catalogue concerned" & vbLf
        If Chart.Range("B8") = "" Then mMissing = mMissing & "- Truck range" & vbLf
        If Chart.Range("D7") = "" Then mMissing = mMissing & "- Standard concerned" & vbLf
        If Chart.Range("D9") = "" Then mMissing = mMissing & "- Time Estimated for correction" & vbLf
        'INFO DOC
                'Infos manquantes
        If Chart.Range("D11") = "" Then mMissing = mMissing & "- Doc Not Correct : Supposed Root Cause" & vbLf
        If Chart.Range("D12") = "" Then mMissing = mMissing & "- Doc Not Correct : Aim of the request" & vbLf
                'Infos en trop
        If Chart.Range("B11") <> "" Then mSpare = mSpare & "- Doc Correct : Supposed Root Cause" & vbLf
        If Chart.Range("B12") <> "" Then mSpare = mSpare & "- Doc Correct : Aim of the request" & vbLf
    End If
    If Chart.Range("B5") = "NO" Then
        'INFO GENERAL
            'Infos manquantes
        If Chart.Range("B2") = "" Then mMissing = mMissing & "- ARGUS case number" & vbLf
        If Chart.Range("B3") = "" Then mMissing = mMissing & "- SPE / SPI name" & vbLf
        If Chart.Range("B5") = "" Then mMissing = mMissing & "- Non-conformity doc confirmation" & vbLf
        If Chart.Range("D2") = "" Then mMissing = mMissing & "- ARGUS case date" & vbLf
        'INFO VEHICULE
                'Infos manquantes
        If Chart.Range("B7") = "" Then mMissing = mMissing & "- Catalogue concerned" & vbLf
        If Chart.Range("B8") = "" Then mMissing = mMissing & "- Truck range" & vbLf
        If Chart.Range("D7") = "" Then mMissing = mMissing & "- Standard concerned" & vbLf
        If Chart.Range("D9") = "" Then mMissing = mMissing & "- Time Estimated for correction" & vbLf
        'INFO DOC
                'Infos manquantes
        If Chart.Range("B11") = "" Then mMissing = mMissing & "- Supposed Root Cause" & vbLf
        If Chart.Range("B12") = "" Then mMissing = mMissing & "- Aim of the request" & vbLf
                'Infos en trop
        If Chart.Range("D11") <> "" Then mSpare = mSpare & "- Supposed Root Cause" & vbLf
        If Chart.Range("D12") <> "" Then mSpare = mSpare & "- Aim of the request" & vbLf
    End If

    'AFFICHAGE
    If mMissing <> "" Then
        MsgBox "Your sheet is missing the following :" & vbLf & mMissing & vbLf & "Save Canceled" & vbCr & "Please complete informations", vbExclamation, "Avertissement"
        Exit Sub
    End If
    
    If mSpare <> "" Then
        MsgBox "Unneeded information in the sheet :" & vbLf & mSpare & vbLf & "Save Canceled" & vbCr & "Please complete informations", vbExclamation, "Avertissement"
        Exit Sub
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'SAUVEGARDE
''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Select Case MsgBox("Chart # : " & sName & vbLf & "will be saved in : " & vbLf & _
                sRep, vbOKCancel + vbInformation)
        Case vbOK
            F.Copy
            With ActiveWorkbook
                For Each N In .Names
                    N.Delete
                Next N
                .ActiveSheet.Range("A1:D12").Validation.Delete
                .SaveAs sDir & "/" & sRep & "/" & sName & ".xlsx", xlOpenXMLWorkbook
                .Close
            End With
            MsgBox "Chart # : " & sName & vbCr & "was saved in :" & vbCr & sRep
            Windows("Argus NC Chart.xlsm").Activate
            Sheets("Chart").Range("B2:B5,D2:D4,B7:B9,D7:D9,B11:B12,D11:D12").ClearContents
        Case vbCancel
            MsgBox "Save Canceled"
    End Select
End Sub

Je me demande comment optimiser mon code.

Merci d'avance pour vos remarques et suggestions.
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
344
M@xu3L
M
halecs93
  • Question
Microsoft 365 Générer mail via Excel
Réponses
2
Affichages
203
halecs93
halecs93
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
215
guiyom
G
L
  • Question
Microsoft 365 Insérer une plage Excel en image sous VBA pour envoi mail auto
Réponses
1
Affichages
111
fanch55
fanch55
S
  • Question
XL 2021 macro VBA excel
Réponses
1
Affichages
160
crocrocro
C
T
  • Question
Microsoft 365 probleme passage paramètre dans une fonction
Réponses
8
Affichages
264
Phil69970
Phil69970
T
  • Résolu(e)
Microsoft 365 optimisation d'un programme en utilisant la fonction Array
Réponses
5
Affichages
220
Thomas_1
T
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
126
GClaire
G
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
89
marie3107
M
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
349
crocrocro
C

Membres actuellement en ligne

15 membres et 141 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 113
Messages
2 085 427
Membres
102 889
dernier inscrit
monsef JABBOUR