Code de Macro qui s'arrête après une instruction sans message d'erreur

**MistyFlip** · 27/07/2017, 16h20

Bonjour à tous,

Je suis actuellement en train de d'écrire une macro qui permet d'ajouter une nouvelle feuille. Cette macro est réalisée dans un fichier XLAM afin d'améliorer la maintenabilité du code. Mon code s'arrête sans message d'erreur au moment ou li exécute la ligne ".Worksheets("Blank_Template (2)").Name = "PART " & lastNumber & "A""

Le code est divisé en plusieurs sous routine

nb : le mots ACTIVE_WORKBOOK est une variable global qui contient l'objet "classeur" sur lequel on travaille elle est transmise comme suis :

Code dans le fichier excel normal (.xlsm)

Code :

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

1
2
3
4
5
6
7
8
9
10
 
 
Sub Button_Add_table
 
Dim book as workbook
 
set book = Workbooks(ActiveWorkbook.name)
 Call MacroTemplateTS.Add_Table(book)
 
end Sub

Et le code dans le XLA :

Code qui affecte la variable global

Code :

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

1
2
3
4
5
6
7
8
9
 
 
Sub Add_Table(book As Workbook, sht As Worksheet) 'OK
 
    Set ACTIVE_WORKBOOK = book
 
    Call add_new_table
 
End Sub

D'abord la sous routine "principale"

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
 
 
Sub add_new_table() 'OK
 
Dim lastNumber As Integer
 
    Call Sort_WorkBook
 
    With ACTIVE_WORKBOOK
        lastNumber = ExtractingNumber(.Worksheets(.Worksheets.Count - 3).Name)
        lastNumber = lastNumber + 1
        .Worksheets("Blank_Template").Visible = True
        .Worksheets("Blank_Template").Copy after:=.Worksheets(.Worksheets.Count - 3)
        .Worksheets("Blank_Template (2)").Name = "PART " & lastNumber & "A"    <---------------- Ligne où le code plante
        .Worksheets("Blank_Template").Visible = False
    End With
 
End Sub

elle appelle la sous routine Sort_Workbook

Code :

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

1
2
3
4
5
6
7
8
 
 
Sub Sort_WorkBook() 'OK
 
    Call Sort_Alphabetically
    Call Order_Table_Number
 
End Sub

Qui appelle elle même deux sous routine

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
 
 
Sub Sort_Alphabetically() 'OK
Dim i, j As Integer
 
    Call Store_Hide_Table
    Call Check_ChangeLog
 
    i = 2 'pass the Change_Log sheet
 
    With ACTIVE_WORKBOOK
        While .Worksheets(i).Name Like "PART *"
            j = i + 1
            While .Worksheets(j).Name Like "PART *"
                If .Worksheets(i).Name > .Worksheets(j).Name Then
                    .Worksheets(j).Move before:=.Worksheets(i)
                End If
                j = j + 1
            Wend
            i = i + 1
        Wend
    End With
 
End Sub

et

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
 
 
Sub Order_Table_Number() 'OK
 
Dim referenceNumber As Integer
Dim referenceLetter As String
Dim newSheetName As String
Dim sheetLetter As String
Dim sheetNumber As Integer
Dim i As Integer
 
    referenceNumber = 1
    referenceLetter = "A"
    i = 2
 
    With ACTIVE_WORKBOOK
        While .Worksheets(i).Name Like "PART *"
            sheetNumber = ExtractingNumber(.Worksheets(i).Name)
 
            If .Worksheets(i + 1).Name Like "PART *" Then
 
                newSheetName = "PART " & referenceNumber & referenceLetter
                'Check the next table to determine the right reference letter and reference number
                If referenceNumber <> ExtractingNumber(.Worksheets(i + 1).Name) And ExtractingNumber(.Worksheets(i + 1).Name) <> ExtractingNumber(.Worksheets(i).Name) Then
                    referenceNumber = referenceNumber + 1
                    referenceLetter = "A"
                Else ' Same variant
                    Select Case (referenceLetter)
                        Case Is = "A"
                            referenceLetter = "B"
                        Case Is = "B"
                            referenceLetter = "C"
                        Case Else
                            referenceLetter = "D"
                    End Select
                End If
            Else 'Last table
                newSheetName = "PART " & referenceNumber & referenceLetter
            End If
                .Worksheets(i).Name = newSheetName
                i = i + 1
        Wend
    End With
 
End Sub

et enfin il y a quelque autre méthodes qui sont appelée de temps en temps

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
 
 
Sub Store_Hide_Table() 'OK
 
    With ACTIVE_WORKBOOK
        If ExistingTable("Blank_Change_Log") = True Then
            .Worksheets("Blank_Change_Log").Visible = True
            .Worksheets("Blank_Change_Log").Move after:=.Worksheets(.Worksheets.Count)
            .Worksheets("Blank_Change_Log").Visible = False
        Else
            MsgBox "The reference ""Blank_Change_Log"" table doesn't exist anymore."
        End If
 
        If ExistingTable("Reference_Sheet") = True Then
            .Worksheets("Reference_Sheet").Visible = True
            .Worksheets("Reference_Sheet").Move after:=.Worksheets(.Worksheets.Count)
            .Worksheets("Reference_Sheet").Visible = False
        Else
            MsgBox "The reference ""Reference_Sheet"" table doesn't exist anymore."
        End If
 
        If ExistingTable("Blank_Template") = True Then
            .Worksheets("Blank_Template").Visible = True
            .Worksheets("Blank_Template").Move after:=.Worksheets(.Worksheets.Count)
            .Worksheets("Blank_Template").Visible = False
        Else
            MsgBox "The reference ""Blank_Template"" table doesn't exist anymore."
        End If
 
    End With
 
End Sub
 
 
Sub Check_ChangeLog() 'OK
 
    With ACTIVE_WORKBOOK
 
        If ExistingTable("Change_Log") = True Then
            .Worksheets("Change_Log").Move before:=.Worksheets(1)
 
        Else
            .Worksheets("Blank_Change_Log").Visible = True
            .Worksheets("Blank_Change_Log").Copy before:=.Worksheets(1)
            .Worksheets("Blank_Change_Log (2)").Name = "Change_Log"
            .Worksheets("Blank_Change_Log").Visible = False
        End If
 
    End With
 
End Sub
 
Function ExistingTable(checktable As String) As Boolean 'OK
 
On Error GoTo mistake
Dim table As Worksheet
 
    ExistingTable = False
    For Each table In ACTIVE_WORKBOOK.Worksheets
        If table.Name = checktable Then
            ExistingTable = True
            Exit Function
        End If
 
    Next table
Exit Function
 
mistake:
    MsgBox "Error..."
    ExistingTable = CVErr(xlErrNA)
 
End Function
 
Function ExtractingNumber(sheetName As String) As Integer 'OK
 
        sheetName = Replace(sheetName, "PART ", "")
 
        If Len(sheetName) = 2 Then
            sheetName = Left(sheetName, Len(sheetName) - 1)
        Else
            sheetName = Left(sheetName, Len(sheetName) - 2)
        End If
 
        ExtractingNumber = CInt(sheetName)
 
End Function
 
Function ExtractingLetter(sheetName As String) As String 'OK
 
        ExtractingLetter = Right(sheetName, 1)
 
End Function

Voila mon code est un peu long mais je ne vois pas d'ou peut venir l'erreur donc je préfère en mettre trop plutôt que trop peu

Invité · 27/07/2017, 16h35

Bonsoir,
Commence par retirer les on error!

**MistyFlip** · 27/07/2017, 16h40

Envoyé par dysorthographie

Bonsoir,
Commence par retirer les on error!

Merci pour ta réponse, je viens de le faire mais ça ne résous pas le problème et n'affiche pas de message d'erreur

**MistyFlip** · 29/07/2017, 12h59

Bonjour,

Voila j'ai réussi a résoudre mon problème d'une façon un peu étrange : J'ai copier/coller le contenu de mon module du fichier excel qui permettait de faire les appels des fonctions contenu dans le XLA. Je l'ai sauvegarder le contenu sur un fichier text (bloc note). J'ai supprimer le module du fichier excel, puis j'en ai recréer un nouveau. Je l'ai renommer de la même façon et j'ai recoller l'intégralité du contenu du fichier text dans le nouveau module. Et la (un peu comme par magie) le problème était résolu.

Code de Macro qui s'arrête après une instruction sans message d'erreur [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager