MACRO VBA a fonctionnement aléatoire (recherche, tri, efface doublons)

Le 26/11/2020 à 09:33

Bonjour

J'aurai besoin d'un petit conseil .

J'ai créé une macro VBA . Elle semble tourner comme il faut mais une fois sur 3 elle bloque dans le vide et fait planter excel. JE me doute, n'étant pas un spécialiste dans ce domaine qu'il y a de l'optimisation à faire mais ne trouve pas comment. Si quelqu'un a la gentillesse (et la patience :) ) de me donner un deux conseils ce serait parfait;.

Voici le principe :

1. j'ai une feuille "maintenance" qui liste des opérations (avec détails, montant, référence bon de commande, etc.)

2. une feuille gros poste qui doit extraire les plus gros montants

3. je créer donc une macro qui demande de définir un seuil, regarde dans la liste des données de la fiche maintenance ceux qui sont supérieurs (montants en colonne F de la fiche maintenance) et les copie dans la feuille "gros postes"

4. ensuite (chaque ligne ayant référencé un bon de commande , en colonne D de la fiche maintenance), je regarde si une ligne correspond au même bon de commande pour intégrer les coûts (donc copier la ligne aussi dans la feuille "gros postes")

5. forcément ma boucle fait apparaître de potentiels doublons (si plusieurs gros montant sont affectés au même bon de commande) et j'essaie de supprimer ces lignes

voici le code

Sub Bouton2_Cliquer()
Worksheets("GROS POSTES").Range("A2:F5000").ClearContents
Worksheets("GROS POSTES").Range("A2:F5000").Borders.LineStyle = xlNone
Range("A2:F5000").Font.Color = RGB(0, 0, 0)
k = 2
nb = 0
Total = 0
Sheets("GROS POSTES").Range("H5") = InputBox("Montant du seuil des dépenses (en euros) ?", "SEUIL")
seuil = Sheets("GROS POSTES").Range("H5")
For j = 2 To 4500
montant = Sheets("maintenance").Range("F" & j)

If montant > seuil Then
Sheets("GROS POSTES").Range("B" & k) = Sheets("maintenance").Range("H" & j)
Sheets("GROS POSTES").Range("C" & k) = Sheets("maintenance").Range("B" & j)
Sheets("GROS POSTES").Range("F" & k) = Sheets("maintenance").Range("D" & j)
Sheets("GROS POSTES").Range("D" & k) = Sheets("maintenance").Range("E" & j)
Sheets("GROS POSTES").Range("E" & k) = Sheets("maintenance").Range("F" & j)
nb = nb + 1
Total = Total + montant

For Z = 2 To 4500
If Sheets("maintenance").Range("D" & Z) = Sheets("maintenance").Range("D" & j) And Sheets("maintenance").Range("F" & Z) < seuil And Sheets("maintenance").Range("F" & j) <> Sheets("maintenance").Range("F" & Z) Then
k = k + 1
nb = nb + 1
Sheets("GROS POSTES").Range("B" & k) = Sheets("maintenance").Range("H" & Z)
Sheets("GROS POSTES").Range("C" & k) = Sheets("maintenance").Range("B" & Z)
Sheets("GROS POSTES").Range("D" & k) = Sheets("maintenance").Range("E" & Z)
Sheets("GROS POSTES").Range("E" & k) = Sheets("maintenance").Range("F" & Z)
Sheets("GROS POSTES").Range("F" & k) = Sheets("maintenance").Range("D" & Z)
Range("F" & k).Font.Color = RGB(255, 0, 0)
montant1 = Sheets("maintenance").Range("F" & Z)
Total = Total + montant1
End If

Next
k = k + 1
End If
Next
Application.ScreenUpdating = False
DerLig = Range("B" & Rows.Count).End(xlUp).Row

Range("A2:F" & DerLig).Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlNo

For i = DerLig - 1 To 7 Step -1
    If Range("F" & i) = Range("F" & i + 1) And Range("E" & i) = Range("E" & i + 1) Then Rows(i).Delete
Next

Range("B2:F4000").Sort Key1:=Range("C2"), Order1:=xlAscending
Range("B2:F4000").Sort Key1:=Range("F2"), Order1:=xlAscending
Range("B2:F4000").Sort Key1:=Range("B2"), Order1:=xlAscending

With Worksheets("GROS POSTES")
    juska = .Range("B2:B" & Rows.Count).SpecialCells(xlCellTypeBlanks).Row - 1
    Set Plage = .Range("B2:F" & juska)
    With Plage.Borders
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = 1
     End With
  End With

 Sheets("GROS POSTES").Range("H14") = nb
   Sheets("GROS POSTES").Range("H15") = Total

End Sub

Merci par avance pour votre aide

Le 26/11/2020 à 11:27

Bonjour,

le fait que certaines références à des cellules sont faites sans indiquer la feuille sur laquelle ces cellules se trouvent, peuvent expliquer le comportement "aléatoire", le comportement de la macro sera différent selon la feuille sélectionnée au moment de l'exécution de la macro.

Sinon, ce serait beaucoup plus simple de t'aider si tu nous mettais un fichier exemple représentatif de ce que tu veux faire.

Le 26/11/2020 à 11:53
15test-depenses-maintenance.zip (320.21 Ko)

J'ai essayé de vous bricoler un petit fichier de test rapide , le bouton est sur la feuille 2 (il faudra que je reprenne l'emplacement de celui ci et du texte car il peut disparaitre lors de la suppression des lignes mais je l'adapterai )

Le fichier reprend donc toutes les commandes supérieures au seuil entré (ex: 10000) et va chercher si de'autres travaux sont associés au meme bon de commande , dans ce cas il les colle et les colorie en rouge , puis supprime les doublons de lignes )

Le 26/11/2020 à 13:04

Bonjour,

une proposition.

Sub Bouton2_Cliquer()
    Set wsg = Sheets("GROS POSTES")
    Set wsm = Sheets("maintenance")
    wsg.Range("A2:F5000").ClearContents
    wsg.Range("A2:F5000").Borders.LineStyle = xlNone
    wsg.Range("A2:F5000").Font.Color = RGB(0, 0, 0)
    wsg.Range("H5") = InputBox("Montant du seuil des dépenses (en euros) ?", "SEUIL")
    seuil = wsg.Range("H5")
    k = 1
    nb = 0
    Total = 0
    With wsm
        dlg = .Cells(Rows.Count, 4).End(xlUp).Row
        .Range("A1:H" & dlg).Sort key1:=.Range("D1"), order1:=xlAscending, key2:=.Range("F1"), order2:=xlDescending, Header:=xlYes
        numerocommande = ""
        For i = 2 To dlg
            If .Cells(i, 4) <> numerocommande Then
                If .Cells(i, 6) > seuil Then
                    acopier = True
                Else
                    acopier = False
                End If
                numerocommande = .Cells(i, 4)
            End If
            If acopier Then
                k = k + 1
                montant = .Range("F" & i)
                wsg.Range("B" & k) = .Range("H" & i)
                wsg.Range("C" & k) = .Range("B" & i)
                wsg.Range("F" & k) = numerocommande
                wsg.Range("D" & k) = .Range("E" & i)
                wsg.Range("E" & k) = montant
                nb = nb + 1
                Total = Total + montant
            End If
        Next i
    End With
    With wsg
        .Range("B2:F" & k).Sort key1:=.Range("B2"), order1:=xlAscending, key2:=.Range("F2"), order2:=xlAscending, key3:=.Range("C2"), order3:=xlAscending, Header:=xlNo
        Set Plage = .Range("B2:F" & k)
        With Plage.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1
        End With
        .Range("H14") = nb
        .Range("H15") = Total
    End With
End Sub
Le 26/11/2020 à 13:23

Re

Merci beaucoup

Ca à l'air de tourner nikel et la macro est super rapide.

Comme quoi avec un bon code propre ca aide (plutot que mon bricolage tout pourri ;)

Rechercher des sujets similaires à "macro vba fonctionnement aleatoire recherche tri efface doublons"