Discussion :

[Gado2600]

Bonjour,

Via une macro, je réalise un "enregistrer sous" et une suppression d'onglets dans un classeur Excel.
Mon problème est que, à partir du moment où des onglets sont supprimés, Excel fige le défilement vertical de l'onglet affiché et m'empêche de fermer l'Excel de manière classique (croix rouge ou alt+f4).
Je suis sous W10. Le problème n'est pas rencontré sur un w8.

Auriez-vous des suggestions ?

Cordialement,

[casefayere]

Bonjour,
et si tu publiais ton code

[Gado2600]

Bonjour,

Ci-dessous:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
Sub SaveEntireFile()
    On Error GoTo errHandler
    Dim oFso                    As Object
    Dim strFolder               As String
    Dim bDelete                 As Boolean
    Dim xlWkBook                As Workbook
    Dim x                       As Worksheet
    Dim xlWkSheet               As Worksheet
    Dim strFile                 As String
    Dim strFileName             As String
    Dim strNumCaisse            As String
    Dim strLien                 As String
    Dim i                       As Long
    Dim strEvents               As String
 
    Set xlWkBook = ThisWorkbook
 
    ' On contrôle l'existence du répertoire
    If F_Params.Range("FolderSave") <> "" Then
        If ExistFolder(F_Params.Range("FolderSave")) Then
            strFolder = F_Params.Range("FolderSave")
        End If
    End If
 
    Set oFso = CreateObject("Scripting.FileSystemObject")
    MsgBox "Veuillez sélectionner le répertoire de sauvegarde du fichier Excel", vbInformation, "Sauvegarde"
 
    ' Chemins potentiels
    strFolder = F_Params.Range("FolderSave")
    If Not ExistFolder(strFolder, , , False) Then strFolder = F_Params.Range("DefaultSaveFolder")
    If Not ExistFolder(strFolder, , , False) Then strFolder = ThisWorkbook.Path
 
    strFileName = [Longueur] & "x" & [Largeur] & "x" & [Hauteur] & "x" & [PoidsNet] & "_" & [TypeEmballage] & "_" & [ClientOF] & "_" & [NumDossier] & ".xlsm"
    strFile = Application.GetSaveAsFilename(initialfilename:=strFolder & IIf(Right(strFolder, 1) Like "\", "", "\") & strFileName, filefilter:="Excel Files (*.xlsm), *.xlsm")
 
    If UCase(strFile) = UCase("Faux") Then
        Call activateSystem
        Exit Sub
    Else
        If strFile <> "Faux" Then ThisWorkbook.SaveAs strFile
        DoEvents
    End If
 
    ' Suppression des onglets non nécessaires
    strNumCaisse = F_Debit_En_Cours.Range("TypeCais")
    For i = 1 To F_Debit_En_Cours.Range("ListeCaisse").Rows.Count
        If UCase(F_Debit_En_Cours.Range("ListeCaisse").Cells(1, 1).Offset(i - 1, 0)) = UCase(strNumCaisse) Then
            strLien = F_Debit_En_Cours.Range("ListeCaisse").Cells(1, 1).Offset(i - 1, 0).Hyperlinks(1).SubAddress
            Set xlWkSheet = Nothing
            On Error Resume Next
            Set xlWkSheet = ThisWorkbook.Worksheets(Replace(Split(strLien, "!")(0), "'", ""))
            On Error GoTo 0
            Exit For
        End If
    Next
 
    Call desactivateSystem
 
    For i = xlWkBook.Worksheets.Count To 1 Step -1
 
        Select Case ThisWorkbook.Worksheets(i).CodeName
            ' Onglets qu'on garde par défaut
            Case F_Emballage.CodeName, F_Emballage_M.CodeName, F_ImprEtiqZebra.CodeName, F_Feuille_Attachement.CodeName, F_Debit_En_Cours.CodeName, F_Epaisseurs.CodeName, F_Params.CodeName, F_Largeurs_Barres.CodeName
                bDelete = False
                If F_Debit_En_Cours.CodeName Like ThisWorkbook.Worksheets(i).CodeName Then
                    F_Debit_En_Cours.UsedRange.Copy
                    F_Debit_En_Cours.UsedRange.PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                End If
'            Case F_Contre_Plaque.CodeName, F_Prix_Revient_Vente.CodeName, F_Rrevient_Vente.CodeName
'                bDelete = False
            ' Onglet à supprimer
            Case Else
                ' Fiche Débit
                If Not xlWkSheet Is Nothing Then
                    If UCase(xlWkSheet.CodeName) Like UCase(ThisWorkbook.Worksheets(i).CodeName) Then
                        bDelete = False
                    Else
                        bDelete = True
                    End If
                Else
                    bDelete = True
                End If
 
        End Select
        Set x = ThisWorkbook.Worksheets(i)
        x.Visible = True
        'Debug.Print Format(i, "00") & " - " & x.CodeName
        If bDelete = True Then x.Delete
        'DoEvents
    Next
 
    ' On prend Débit en cours si on n'a pas d'onglet Fiche Débit
    If xlWkSheet Is Nothing Then Set xlWkSheet = F_Debit_En_Cours
    Dim xlWkShape       As Shape
    ' On ne laisse que l'onglet débit d'afficher et on masque les autres
    For Each x In ThisWorkbook.Worksheets
        For Each xlWkShape In x.Shapes
            strEvents = xlWkShape.OnAction
            If strEvents <> "" Then
                strEvents = Split(strEvents, "!")(UBound(Split(strEvents, "!")))
                Select Case UCase(strEvents)
                    ' On conserve
                    Case UCase("ImpCaisse"), UCase("AnnulImpres")
                        ' On ne fait rien
                    ' On supprime
                    Case UCase("Feuil_Menu_Debit"), UCase("SaisieDébit")
                        xlWkShape.Delete
                    Case Else
                        ' On ne fait rien
                End Select
            End If
        Next
 
        If x.CodeName Like xlWkSheet.CodeName Then
            x.Visible = True
        Else
            x.Visible = False
        End If
    Next
    Call activateSystem
    ThisWorkbook.Save
 
    Exit Sub
errHandler:
    Call activateSystem
    MsgBox "Erreur N°" & Err.Number & " :" & vbCrLf & Err.Description, vbExclamation, "Erreur"
End Sub

ActivateSystem et desactivateSystem sont identiques sur la procédure :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Sub activateSystem(Optional bScreenUpdating As Boolean = True, Optional bEnableEvents As Boolean = True, Optional bCalculationMode As Boolean = True, Optional bDisplayAlerts As Boolean = True, Optional bAskToUpdateLinks As Boolean = True)
    If bScreenUpdating Then Application.ScreenUpdating = True
    If bEnableEvents Then Application.EnableEvents = True
    If bCalculationMode Then Application.Calculation = xlCalculationAutomatic
    If bDisplayAlerts Then Application.DisplayAlerts = True
    If bAskToUpdateLinks Then Application.AskToUpdateLinks = True
End Sub

Quand à ExistFolder, il s'agit d'une fonction m'indiquant si le répertoire existe ou non.

Cordialement,