Code de Macro qui s'arrête après une instruction sans message d'erreur
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:
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:
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:
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:
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:
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:
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:
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
