Excel : macro pour detecter une erreur

Question

Bonjour à tous, 

Je lance un nouveau sujet aujourd'hui concernant une macro que je dois modifier (ou remplacer) : elle a pour but de me signaler une erreur type #ref, #Value, #Div/0 et de signaler aussi s'il traine une "," dans mon classeur. 
Elle fonctionne parfaitement aujourd'hui mais comme mon classeur est du genre plutôt vaste, je dois à présent signaler la page, voir même la cellule si possible, qui est en défaut ! 
Si quelqu'un de la communauté cçm a par hasard déjà vu ou réalisé ce type d'opération je suis à votre écoute ! 
Je rappelle que je travail sous Excel 2003. 


Bbye merci à vous. 



Configuration: Windows XP / Internet Explorer 7.0

michel_m · Accepted Answer

Bonjour

ci dessous macro simplifiée pour donner en feuille 3 les adresses des erreurs et virgules à compléter et/ou adapter par tes soins. ci joint maquette de travail

Dim Erreurs, Virgules
Dim cptr_e As Integer, cptr_v As Integer

Sub chercherlerreur()
Dim cptr As Byte
Dim onglets, plages
Dim onglet As String, plage As String


onglets = Array("devis elec", "questionnaire") 'à complèter
plages = Array("B2:B6", "A2:A6") 'a complèter

ReDim Erreurs(1, 0)
ReDim Virgules(1, 0)

For cptr = 0 To UBound(onglets)
    onglet = onglets(cptr)
    plage = plages(cptr)
    verifier onglet, plage
Next

With Sheets(3)
Application.ScreenUpdating = False
.Range("B2:F1000").Clear
.Range("B2").Resize(UBound(Erreurs) + 1, 2) = Application.Transpose(Erreurs)
.Range("E2").Resize(UBound(Virgules) + 1, 2) = Application.Transpose(Virgules)

End With
End Sub


Sub verifier(feuille, zone)
Dim cellule As Range

With Sheets(feuille)
For Each cellule In .Range(zone)
If IsError(cellule) Then
    Erreurs(0, cptr_e) = feuille
    Erreurs(1, cptr_e) = cellule.Address
    cptr_e = cptr_e + 1
    ReDim Preserve Erreurs(1, cptr_e)

End If

test = cellule.Address
If cellule.Text Like "*,*" Then
    Virgules(0, cptr_v) = feuille
    Virgules(1, cptr_v) = cellule.Address
    cptr_v = cptr_v + 1
    ReDim Preserve Virgules(1, cptr_v)

End If
Next
End With

End Sub


demo
https://www.cjoint.com/?eqnsVsUoNV

Le Pingou · Answer

Bonjour,
Alors mettez une copie de votre macro pour voir ou intégrer une balise de position!

logan989 · Answer

Bonjour, 

Voici ladite macro : 

Public HeureExecution As Double
Public NomClasseur As Variant


Public flagouverture As Boolean, flagref As Boolean, flagvirgule As Boolean

Public Sub ExecuterTimer()
    
    Dim toto As Variant
    
    NomClasseur = ThisWorkbook.Name
    '************** Vérification des valeurs de cellules
    
    a = 0
    b = 0
    

    '**** Vérif de certaines feuilles uniquement
    For Each c1 In Workbooks(NomClasseur).Worksheets("Devis ELEC").Range("A1:M80")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
            
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Questionnaire").Range("A1:I80")
        If IsError(c1) Then
            a = a + 1
        End If
        
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Liste actionneur-Alimentation").Range("A1:BL200")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Liste instrumentation").Range("A1:R370")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Tertiaire").Range("A1:CT120")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("armoires").Range("A1:I26")
        If IsError(c1) Then
            a = a + 1
        End If
    
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Dimensionnement armoire(s)").Range("A1:M36")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Coût armoires et coffrets").Range("A1:J60")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Récapitulatif câbles").Range("A1:Y130")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Calcul du transformateur").Range("A1:Y130")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    For Each c1 In Workbooks(NomClasseur).Worksheets("Refroidissement").Range("A1:Y400")
        If IsError(c1) Then
            a = a + 1
        End If
        If c1.Text Like "*,*" Then
            b = b + 1
        End If
    Next
    
  
 
    
    'MsgBox ("Nombre cellules en erreur:" & a & " Flag ref:" & flagref & "  Flag ouv:" & flagouverture)

    If a > 0 And flagref = False Then
        ' Il y a un #ref, #Value, #Div/0 qui traine
        toto = MsgBox("Une ou plusieurs cellules sont en erreur dans le fichier!", vbCritical, ThisWorkbook.Name)
        
        flagref = True
    ElseIf a = 0 And flagref = True Then
        ' Tout est ok
        flagref = False
        toto = MsgBox("Plus d'erreur dans les cellules.", vbInformation)
    End If
    
    '*******************
    If b > 0 And flagvirgule = False Then
        ' Il y a une virgule qui traîne quelque part
        toto = MsgBox("Une ou plusieurs cellules contiennent le caractère virgule :',' Voir avec EAS.", vbCritical, ThisWorkbook.Name)
        
        flagvirgule = True
    ElseIf b = 0 And flagvirgule = True Then
        ' Tout est ok
        flagvirgule = False
        toto = MsgBox("Plus de virgule.", vbInformation)
    End If

    '******** Vérification du nombre de feuille ouvertes
    If Workbooks.Count > 1 And flagouverture = False Then
        toto = MsgBox("Plus d'un fichier ouvert dans la même instance d'Excel! Fermer les autres fichiers ouverts ou ouvrir la note de calcul Elec dans un nouvel Excel.", vbCritical, ThisWorkbook.Name)
        flagouverture = True
        
    ElseIf Workbooks.Count = 1 And flagouverture = True Then
        flagouverture = False
        
    End If

    If flagouverture Or flagref Or flagvirgule Then
        Workbooks(NomClasseur).Worksheets("Devis ELEC").Range("H69").Value = "ERREUR"
    Else
        Workbooks(NomClasseur).Worksheets("Devis ELEC").Range("H69").Value = ""
    End If
    
    
    
    HeureExecution = Now + TimeSerial(0, 5, 0)
    Application.OnTime HeureExecution, "ExecuterTimer", , True
    
    
    
End Sub
Public Sub StopTimer()

    Application.OnTime HeureExecution, "ExecuterTimer", , False
    
    
End Sub


J'espère que ça pourra vous aider.

logan989 · Answer

Encore une question michel_m : pour ta macro, une erreur se produit souvent :  

Erreur d'execution '9' : l'indice n'appartient pas à la sélection 

 La ligne 38 est surlignée quand je clique sur débogage :  Erreurs(0, cptr_e) = feuille 

As-tu l'explication ?

michel_m · Answer

Re,

effectivement, il y avait ce piège et d'autres dans lesquels je suis tombé (ça, je sais bien faire)
ci joint le classeur modifié avec en petit supplément gratuit un splendide chronomètre à la milliseconde
https://www.cjoint.com/?eqsRDTWUrE

Mes bourdes?

dans "chercherlerreur"
With Sheets(3)
    Application.ScreenUpdating = False
    .Range("B2:F1000").Clear
    .Range("B2").Resize(cptr_e, 2) = Application.Transpose(Erreurs)
    .Range("E2").Resize(cptr_v, 2) = Application.Transpose(Virgules)
End With
Set Erreurs = Nothing
Set Virgules = Nothing
cptr_e = 0
cptr_v = 0


dans "vérifier" (la cellule en erreur empèche de tester la virgul: il faut employer un elseif==> sinon si)
la virgule peur être dans du texte (t'avais bien vu le truc) mais aussi dans un nombre

For Each cellule In .Range(zone)
        If IsError(cellule) Then
            Erreurs(0, cptr_e) = feuille
            Erreurs(1, cptr_e) = cellule.Address
            cptr_e = cptr_e + 1
            ReDim Preserve Erreurs(1, cptr_e)
        ElseIf cellule Like "*,*" Or cellule Like "#,#" Then
            Virgules(0, cptr_v) = feuille
            Virgules(1, cptr_v) = cellule.Address
            cptr_v = cptr_v + 1
            ReDim Preserve Virgules(1, cptr_v)
        End If
    Next

excuses moi pour ces c... (au choix) j'espère que ce coup ci ce sera OK

tu dis (je serai en ballade ce samedi)

Le Pingou · Answer

Bonjour,
Excusez-moi de cette petite intrusion, s'il vous est possible de mettre votre fichier qui fait probléme sur https://www.cjoint.com/ et poster le lien se serait plus simple de trouver la gentillesse ...

michel_m · Answer

essayes comme ceci, peut-être que...
With Sheets("Erreurs")
    .Range("B2:F1000").Clear
   
    For cptr = 0 To cptr_e - 1
        .Cells(2 + cptr, 2) = Erreurs(0, cptr)
        .Cells(2 + cptr, 3) = Erreurs(1, cptr)
    Next
    For cptr = 0 To cptr_v - 1
        Cells(2 + cptr, 5) = Virgules(0, cptr)
        .Cells(2 + cptr, 6) = Virgules(1, cptr)
    Next
    .Activate
    Application.ScreenUpdating = False
End With

Le Pingou · Answer

Bonjour logan989,
En supposant que les diverses procédures se trouvent  dans le module sur lequel  vous coller la procédure de michel_m,  est-il possible d'obtenir le contenu de votre module copier  sur un document Word via un message privé !

Le Pingou · Answer

Bonjour logan989,
Vous avez  copier/coller dans votre  module la procédure de michel-m, cependant avez-vous aussi copier/coller les 2 déclarations au niveau du module ?
Dim Erreurs, Virgules
Dim cptr_e As Long, cptr_v As Long

J'ai fait un essai et si (Dim cptr_ ....) manque, j'obtient le message: erreur d'execution '1004' : Erreur définie par l'application ou par l'objet

Le Pingou · Answer

Bonjour, 
Je suppose qu'il y a un disfonctionnement au niveau du classeur; essayer de copier les feuilles du classeur vers un nouveau classeur sans oublier le/les module/s.  
Salutations. 
Le Pingou

Le Pingou · Answer

Bonjour, 
C'est étonnant que vous avez des références à votre ancien fichier. 

En marge, vous pouvez mettre le fichier compresser en ZIP ou RAR sur https://www.cjoint.com/ ou http://cijoint.fr/ et poster le lien sur un MP via mon profil. 
Salutations. 
Le Pingou

Excel : macro pour detecter une erreur

11 réponses

Votre réponse

Newsletters