VBA - Contenu illisible à l'ouverture du fichier
Bonjour!
Quand j'ouvre le fichier excel, le message d'erreur suivant apparait:
"Désolé...Nous avons trouvé un problème dans le contenu de NomDuFichier.xlsm, mais nous pouvons essayer de récupérer le maximum de contenu. Si la source de ce classeur est fiable, cliquez sur Oui."
Après avoir cliqué sur "Oui", un second message d'erreur apparaît:
"Excel a pu ouvrir le fichier en supprimant ou en réparant le contenu illisible:
- Enregistrements supprimés: Tri dans la partie /xl/worksheets/sheet2.xml"
Excel me force ensuite à enregistrer une nouvelle version du fichier, si j'ai utilité le macro, lors de la réouverture de celui-ci.
J'utilise un macro VBA pour trier automatiquement les données puis pour éliminer les dupliqués. Voici le code de Sheet2.xlm:
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
|
Private Sub CommandButton2_Click()
'TRIER LES DONNÉES
Dim FinalRow As Long
'Find last used row in destination sheet
FinalRow = Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("CTB").Sort
.SortFields.Add Key:=Range("B1"), Order:=xlAscending
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SortFields.Add Key:=Range("C1"), Order:=xlAscending
.SortFields.Add Key:=Range("D1"), Order:=xlAscending
.SortFields.Add Key:=Range("G1"), Order:=xlAscending
.SetRange Range("A1:H" & FinalRow)
.Header = xlYes
.Apply
End With
'***ENLEVER LES DOUBLONS***
Dim x As Integer
Dim y As Integer
Dim LastRow As Long
'FIND THE LAST USED ROW IN A SHEET AND COPY PASTE BELOW IT
'Find last used row in destination sheet
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To LastRow
For y = LastRow To 2 Step by - 1
If Worksheets("CTB").Range("A" & x).Value = Worksheets("CTB").Range("A" & y).Value _
And Worksheets("CTB").Range("B" & x).Value = Worksheets("CTB").Range("B" & y).Value _
And Worksheets("CTB").Range("C" & x).Value = Worksheets("CTB").Range("C" & y).Value _
And Worksheets("CTB").Range("D" & x).Value = Worksheets("CTB").Range("D" & y).Value _
And x <> y _
Then
Worksheets("CTB").Rows(y).Delete
LastRow = LastRow - 1
End If
Next y
Next x
End Sub |
Quelqu'un peut-il m'aider à corriger le code pour éviter l'apparition de messages d'erreur?
Merci! :)
