Assembler 2 macros

Le 03/10/2016 à 21:10

Bonjour à tous et à toute,

N'étant pas un expert sur le logiciel excel, j'aimerais savoir s'il est possible de mettre 2 macros ensemble pour m'éviter 2 manipulations. A ce jour, j'ai une macro qui me permet de trier du matériel en fonction des doublons pour me les comptabilisé, et une autre macro qui me permet, à chaque changement de référence, de me les trier par couleurs.

Je vous met en pièce jointe les 2 fichiers qui ont les macros.

Le fichier Fichier pour nomenclature à ne pas supprimer11 - Copie sera mon fichier de base pour faire mes nomenclatures de schémas

Si quelqu'un peut m'aider, cela serait super cool de sa part.

Merci d'avance

18nomenclature-u-0351-alterner-les-couleurs-copie.zip (17.47 Ko)
18fichier-pour-nomenclature-a-ne-pas-supprimer11-copie1.xlsm (25.18 Ko)
Le 04/10/2016 à 00:41

Bonjour,

Voici le code à mettre dans le fichier Techni-Métal-Systèmes :

Option Explicit

Const LigDeb As Long = 2
Const NbCol As Long = 8

Sub classement()
   Dim TotalLigne As Long, Ref As String, Quantite As Double, i As Long, j As Long
   TotalLigne = ThisWorkbook.Sheets("Liste des composant").Range("A65536").End(xlUp).Row

   For i = LigDeb To TotalLigne

      Ref = ThisWorkbook.Sheets("Liste des composant").Cells(i, 2)
      Quantite = ThisWorkbook.Sheets("Liste des composant").Cells(i, 4)
      For j = i + 1 To TotalLigne
         If ThisWorkbook.Sheets("Liste des composant").Cells(j, 2) = Ref Then
            Quantite = Quantite + ThisWorkbook.Sheets("Liste des composant").Cells(j, 4)
            ThisWorkbook.Sheets("Liste des composant").Rows(j).Select
            Selection.Delete Shift:=xlUp
            TotalLigne = TotalLigne - 1
            j = j - 1
         End If
      Next j
      ThisWorkbook.Sheets("Liste des composant").Cells(i, 4) = Quantite
   Next i

   Call Alterner

End Sub

Sub Alterner()
   Dim Couleur
   Dim DerLig As Long
   Dim i As Long, n As Long
   Couleur = Array(48, 24)
   DerLig = Range("E" & Rows.Count).End(xlUp).Row
   For i = LigDeb To DerLig
      If Application.CountIf(Range("E" & LigDeb).Resize(i - LigDeb + 1), Range("E" & i).Value) = 1 Then n = (n + 1) Mod 2
      Range("A" & i).Resize(, NbCol).Interior.ColorIndex = Couleur(n)
   Next i
End Sub

Tu peux copier le code aussi dans l'autre fichier, mais il faut changer les deux variables :

Const LigDeb As Long = 10
Const NbCol As Long = 7

En remplaçant le 10 par un 2 car la première ligne est la seconde et le 7 par un 8, car il y a une colonne de plus "Monté par".

Le 04/10/2016 à 21:26

Nickel Benoit, au top.

Celle petit bémol, rien de grave, c'est juste que ça me rajoute des zéros sur les lignes qui ont été supprimé.

Merci encore

Le 05/10/2016 à 22:31

Bonsoir,

C'est parce que tu as une boucle qui va de LigDeb jusqu'à TotalLigne. Le fait que tu décrémentes "TotalLigne = TotalLigne - 1" n'y change rien, la boucle se fait sur la valeur initiale de TotalLigne. Je m'explique, si au démarrage de la boucle, Le total de lignes est de 100, même si tu supprimes des lignes et réduit la valeur de TotalLigne, la boucle ira jusqu'à 100. Il faut donc mettre

If i > TotalLigne Then Exit For

juste après le démarrage de la boucle.

Cela donne ceci :

Option Explicit

Const LigDeb As Long = 2
Const NbCol As Long = 8

Sub classement()
   Dim TotalLigne As Long, Ref As String, Quantite As Double, i As Long, j As Long
   TotalLigne = ThisWorkbook.Sheets("Liste des composant").Range("A65536").End(xlUp).Row

   For i = LigDeb To TotalLigne
      If i > TotalLigne Then Exit For
      Ref = ThisWorkbook.Sheets("Liste des composant").Cells(i, 2)
      Quantite = ThisWorkbook.Sheets("Liste des composant").Cells(i, 4)
      For j = i + 1 To TotalLigne
         If ThisWorkbook.Sheets("Liste des composant").Cells(j, 2) = Ref Then
            Quantite = Quantite + ThisWorkbook.Sheets("Liste des composant").Cells(j, 4)
            ThisWorkbook.Sheets("Liste des composant").Rows(j).Select
            Selection.Delete Shift:=xlUp
            TotalLigne = TotalLigne - 1
            j = j - 1
         End If
      Next j
      ThisWorkbook.Sheets("Liste des composant").Cells(i, 4) = Quantite
   Next i

   Call Alterner

End Sub

Sub Alterner()
   Dim Couleur
   Dim DerLig As Long
   Dim i As Long, n As Long
   Couleur = Array(48, 24)
   DerLig = Range("E" & Rows.Count).End(xlUp).Row
   For i = LigDeb To DerLig
      If Application.CountIf(Range("E" & LigDeb).Resize(i - 1), Range("E" & i).Value) = 1 Then n = (n + 1) Mod 2
      Range("A" & i).Resize(, NbCol).Interior.ColorIndex = Couleur(n)
   Next i
End Sub

Tu peux aussi remplacer la boucle For/Next par une boucle Do Until / Loop (ou Do While / Loop). Cela donne cela :

Option Explicit

Const LigDeb As Long = 2
Const NbCol As Long = 8

Sub classement()
   Dim TotalLigne As Long, Ref As String, Quantite As Double, i As Long, j As Long
   TotalLigne = ThisWorkbook.Sheets("Liste des composant").Range("A65536").End(xlUp).Row

   i = LigDeb
   Do Until i > TotalLigne
      Ref = ThisWorkbook.Sheets("Liste des composant").Cells(i, 2)
      Quantite = ThisWorkbook.Sheets("Liste des composant").Cells(i, 4)
      For j = i + 1 To TotalLigne
         If ThisWorkbook.Sheets("Liste des composant").Cells(j, 2) = Ref Then
            Quantite = Quantite + ThisWorkbook.Sheets("Liste des composant").Cells(j, 4)
            ThisWorkbook.Sheets("Liste des composant").Rows(j).Select
            Selection.Delete Shift:=xlUp
            TotalLigne = TotalLigne - 1
            j = j - 1
         End If
      Next j
      ThisWorkbook.Sheets("Liste des composant").Cells(i, 4) = Quantite
      i = i + 1
   Loop

   Call Alterner

End Sub

Sub Alterner()
   Dim Couleur
   Dim DerLig As Long
   Dim i As Long, n As Long
   Couleur = Array(48, 24)
   DerLig = Range("E" & Rows.Count).End(xlUp).Row
   For i = LigDeb To DerLig
      If Application.CountIf(Range("E" & LigDeb).Resize(i - 1), Range("E" & i).Value) = 1 Then n = (n + 1) Mod 2
      Range("A" & i).Resize(, NbCol).Interior.ColorIndex = Couleur(n)
   Next i
End Sub
Le 05/10/2016 à 22:41

Merci Benoit,

Cela fonctionne mais petit hic, maintenant le changement de couleur en fonction des fabricants ne fonctionnent plus, ou du moins, il m'oublie de faire des changements de couleurs, me met plusieurs fabricant ensemble etc ...

Désolé mais je suis pas encore un pro d'Excel, vas falloir que je me forme

Le 06/10/2016 à 00:36

Effectivement, je suis reparti d'une ancienne version de test. Voici la version corrigée :

Option Explicit

Const LigDeb As Long = 10
Const NbCol As Long = 7

Sub classement()
   Dim TotalLigne As Long, Ref As String, Quantite As Double, i As Long, j As Long
   TotalLigne = ThisWorkbook.Sheets("Liste des composant").Range("A65536").End(xlUp).Row

   For i = LigDeb To TotalLigne
      If i > TotalLigne Then Exit For
      Ref = ThisWorkbook.Sheets("Liste des composant").Cells(i, 2)
      Quantite = ThisWorkbook.Sheets("Liste des composant").Cells(i, 4)
      For j = i + 1 To TotalLigne
         If ThisWorkbook.Sheets("Liste des composant").Cells(j, 2) = Ref Then
            Quantite = Quantite + ThisWorkbook.Sheets("Liste des composant").Cells(j, 4)
            ThisWorkbook.Sheets("Liste des composant").Rows(j).Select
            Selection.Delete Shift:=xlUp
            TotalLigne = TotalLigne - 1
            j = j - 1
         End If
      Next j
      ThisWorkbook.Sheets("Liste des composant").Cells(i, 4) = Quantite
   Next i

   Call Alterner2

End Sub

Sub Alterner()
   Dim Couleur
   Dim DerLig As Long
   Dim i As Long, n As Long
   Couleur = Array(48, 24)
   DerLig = Range("E" & Rows.Count).End(xlUp).Row
   For i = LigDeb To DerLig
      If Application.CountIf(Range("E" & LigDeb).Resize(i - LigDeb + 1), Range("E" & i).Value) = 1 Then n = (n + 1) Mod 2
      Range("A" & i).Resize(, NbCol).Interior.ColorIndex = Couleur(n)
   Next i
End Sub
Le 06/10/2016 à 09:41

Nickel benoit cela fonctionne nickel, j'ai juste supprimer le 2 au niveau de call alterner2 et cela fonctionne parfaitement.

Je vais être encore chiant mais est-il possible qu'une fois le tri effectué et le changement de couleur en fonction des fabricants, faire toute les bordures des cellules une fois le tri et le changement de couleur effectués.

Merci encore pour tout.

C'est top d'avoir des gens comme vous

Rechercher des sujets similaires à "assembler macros"