Classement et mises en forme de données via macro
Bonjour à tous,
Je vous lance un petit SOS car je ne sais pas trop comment m'y prendre pour mettre en forme mon classement des founisseurs.
J'ai un premier tableur dans lequel, j'importe toutes mes données.
Pour les trier dans un premier temps, j'ai fais un bout de code, qui me permet de ne retenir que les fournisseurs nous ayant livrés des produits non-conformes.
Ensuite, je les classe en 8 groupes.
Voici la macro qui me permet de faire :
Sub Bouton2_Cliquer()
Dim PPM As Long, NB_FNC As Integer, QSC As Double, CA As Long
Dim i As Integer, j As Integer
Dim DernLigne As Long
With Worksheets("Feuil1")
For i = 2 To 138
PPM = .Cells(i, "S")
NB_FNC = .Cells(i, "T")
QSC = .Cells(i, "U")
CA = .Cells(i, "V")
'Groupe 8
If NB_FNC = 1 And PPM < 20000 And QSC > 0.85 Then
'__________________
' TEST
'__________________
'If Cells(i, "BN") = "" Then
'.Cells(i, "BN") = .Cells(i, "O")
'.Cells(i, "BN").Interior.Color = RGB(0, 176, 80)
'Else
'While Cells(i, "BN") <> ""
' emplacement = Cells(i, "BN").Value
' emplacement = j + 1
'Wend
'.Cells(i, "BN") = .Cells(i, "O")
'.Cells(i, "BN").Interior.Color = RGB(0, 176, 80)
'End If
'________________________
' FIN DU TEST
'________________________
.Cells(i, "BN") = .Cells(i, "O")
.Cells(i, "BN").Interior.Color = RGB(0, 176, 80)
.Cells(i, "BO") = .Cells(i, "S")
.Cells(i, "BO").Interior.Color = RGB(0, 176, 80)
.Cells(i, "BP") = .Cells(i, "T")
.Cells(i, "BP").Interior.Color = RGB(0, 176, 80)
.Cells(i, "BQ") = .Cells(i, "U")
.Cells(i, "BQ").Interior.Color = RGB(0, 176, 80)
.Cells(i, "BR") = .Cells(i, "V")
.Cells(i, "BR").Interior.Color = RGB(0, 176, 80)
'If NB_FNC = 1 And PPM < 20000 And QSC > 0.85 Then
'With .Range("BN" & i & ":BR" & i)
'.Value = .Range("O" & i & ":V" & i)
'.Interior.Color = RGB(0, 176, 80)
'End With
'Groupe 7
ElseIf NB_FNC = 1 And PPM < 20000 And QSC < 0.85 Then
.Cells(i, "BH") = .Cells(i, "O")
.Cells(i, "BH").Interior.Color = RGB(196, 215, 155)
.Cells(i, "BI") = .Cells(i, "S")
.Cells(i, "BI").Interior.Color = RGB(196, 215, 155)
.Cells(i, "BJ") = .Cells(i, "T")
.Cells(i, "BJ").Interior.Color = RGB(196, 215, 155)
.Cells(i, "BK") = .Cells(i, "U")
.Cells(i, "BK").Interior.Color = RGB(196, 215, 155)
.Cells(i, "BL") = .Cells(i, "V")
.Cells(i, "BL").Interior.Color = RGB(196, 215, 155)
'Groupe 6
ElseIf NB_FNC = 1 And PPM > 20000 And QSC > 0.85 Then
.Cells(i, "BB") = .Cells(i, "O")
.Cells(i, "BB").Interior.Color = RGB(216, 228, 188)
.Cells(i, "BC") = .Cells(i, "S")
.Cells(i, "BC").Interior.Color = RGB(216, 228, 188)
.Cells(i, "BD") = .Cells(i, "T")
.Cells(i, "BD").Interior.Color = RGB(216, 228, 188)
.Cells(i, "BE") = .Cells(i, "U")
.Cells(i, "BE").Interior.Color = RGB(216, 228, 188)
.Cells(i, "BF") = .Cells(i, "V")
.Cells(i, "BF").Interior.Color = RGB(216, 228, 188)
'Groupe 5
ElseIf NB_FNC = 1 And PPM > 20000 And QSC < 0.85 Then
.Cells(i, "AV") = .Cells(i, "O")
.Cells(i, "AV").Interior.Color = RGB(235, 241, 222)
.Cells(i, "AW") = .Cells(i, "S")
.Cells(i, "AW").Interior.Color = RGB(235, 241, 222)
.Cells(i, "AX") = .Cells(i, "T")
.Cells(i, "AX").Interior.Color = RGB(235, 241, 222)
.Cells(i, "AY") = .Cells(i, "U")
.Cells(i, "AY").Interior.Color = RGB(235, 241, 222)
.Cells(i, "AZ") = .Cells(i, "V")
.Cells(i, "AZ").Interior.Color = RGB(235, 241, 222)
'Groupe 4
ElseIf NB_FNC > 2 And PPM < 20000 And QSC > 0.85 Then
.Cells(i, "AP") = .Cells(i, "O")
.Cells(i, "AP").Interior.Color = RGB(255, 255, 0)
.Cells(i, "AQ") = .Cells(i, "S")
.Cells(i, "AQ").Interior.Color = RGB(255, 255, 0)
.Cells(i, "AR") = .Cells(i, "T")
.Cells(i, "AR").Interior.Color = RGB(255, 255, 0)
.Cells(i, "AS") = .Cells(i, "U")
.Cells(i, "AS").Interior.Color = RGB(255, 255, 0)
.Cells(i, "AT") = .Cells(i, "V")
.Cells(i, "AT").Interior.Color = RGB(255, 255, 0)
'Groupe 3
ElseIf NB_FNC > 2 And PPM < 20000 And QSC < 0.85 Then
.Cells(i, "AJ") = .Cells(i, "O")
.Cells(i, "AJ").Interior.Color = RGB(252, 213, 180)
.Cells(i, "AK") = .Cells(i, "S")
.Cells(i, "AK").Interior.Color = RGB(252, 213, 180)
.Cells(i, "AL") = .Cells(i, "T")
.Cells(i, "AL").Interior.Color = RGB(252, 213, 180)
.Cells(i, "AM") = .Cells(i, "U")
.Cells(i, "AM").Interior.Color = RGB(252, 213, 180)
.Cells(i, "AN") = .Cells(i, "V")
.Cells(i, "AN").Interior.Color = RGB(252, 213, 180)
'Groupe 2
ElseIf NB_FNC > 2 And PPM > 20000 And QSC > 0.85 Then
.Cells(i, "AD") = .Cells(i, "O")
.Cells(i, "AD").Interior.Color = RGB(250, 191, 143)
.Cells(i, "AE") = .Cells(i, "S")
.Cells(i, "AE").Interior.Color = RGB(250, 191, 143)
.Cells(i, "AF") = .Cells(i, "T")
.Cells(i, "AF").Interior.Color = RGB(250, 191, 143)
.Cells(i, "AG") = .Cells(i, "U")
.Cells(i, "AG").Interior.Color = RGB(250, 191, 143)
.Cells(i, "AH") = .Cells(i, "V")
.Cells(i, "AH").Interior.Color = RGB(250, 191, 143)
'Groupe 1
ElseIf NB_FNC > 2 And PPM > 20000 And QSC < 0.85 Then
.Cells(i, "X") = .Cells(i, "O")
.Cells(i, "X").Interior.Color = RGB(255, 0, 0)
.Cells(i, "Y") = .Cells(i, "S")
.Cells(i, "Y").Interior.Color = RGB(255, 0, 0)
.Cells(i, "Z") = .Cells(i, "T")
.Cells(i, "Z").Interior.Color = RGB(255, 0, 0)
.Cells(i, "AA") = .Cells(i, "U")
.Cells(i, "AA").Interior.Color = RGB(255, 0, 0)
.Cells(i, "AB") = .Cells(i, "V")
.Cells(i, "AB").Interior.Color = RGB(255, 0, 0)
End If
Next i
End With
End SubPas besoin de le dire, cette macro est loin d'être optimale donc si vous avez des remarques/conseils, je suis preneur !
Mon besoin :
J'aimerais avoir le classement de mes fournisseurs sur une seule page (voir la 2ème PJ --> ).
Si possible j'aimerais que le classement s'effectue sur 3 colonnes de la ligne 1 à la ligne 44.
Si on peut réaliser ce classement sur une feuille 2, ca serait parfait !
Ci-joint, le fichier.
En espérant que vous pourrez me venir en aide durant cet été bien pluvieux,
Merci d'avance,
Edit : Les fichiers ont été supprimés pour cause de confidentialité
Floo73
Bonjour,
Avant d'aller plus loin, dans la Feuille 1 ils sont 137 au départ colonne O et seulement 113 à l'arrivée. (Colonne X, AD, AJ, AP, AV BB...)
C'est comme pour le tour de France il ya des abandons en cours de route ?
Entre ces colonnes et la feuille 2, 7 autres fournisseurs ont disparus de la feuille2
Est-ce normal ou est-ce une erreur de copier/coller ?
Si je réintègre les manquants dans la feuille (2 dans le groupe 1 et 2 dans le groupe 2) je vais avoir 48 lignes au lieu de 44
Est-ce grave docteur ?
Faut il absolument mettre les groupes dans l'ordre ou ils sont (321, 654, 87)
A+
Bonjour Galopin,
Merci de me venir en aide et de prendre ce problème à bras le corps !
Effectivement, je n'avais pas vu la perte au feu ... C'est pas normal qu'on passe de 137 à 113 effectivement, je pense que ce phénomène se produit, car certains fournisseurs ne rentrent pas dans mes conditions IF qui me permettent de faire la classification en groupes ...
Pas de souci pour réintégrer les manquants ! La contrainte de 44 lignes n'est pas une exigence forte, c'est juste que ca facilite ma mise en page pour la présentation sur une feuille A4 de tous mes groupes de fournisseurs.
Je ne suis pas sur de bien comprendre ta dernière question, mais effectivement, si on peut avoir les fournisseurs du groupe 1 en haut de la colonne puis ceux du groupe 2 à la suite et ainsi de suite ca m'irait parfaitement.
Je suis à ta disposition, si tu as d'autres questions, je peux même te donner mon numéro par message perso.
Bon après-midi à toi,
Cdlt,
Floo73
Pour la perte au feu j'ai plus ou moins trouvé !
Donc mes multiples conditions IF, j'avais un FNC = 1 et FNC > 2 ... ca ne prenait donc pas en compte les fournisseurs avec des FNC >= 2 ...
Avec cet oubli de recifié j'arrive à 134 fournisseurs sur 137 dans le tableau
A voir pour les 3 derniers --> je mène mon enquête en attendant avec impatience ta réponse !
Merci en tout cas pour avoir attiré mon attention sur ce point !
Bonsoir,
Les 3 manquants sont ceux qui n'ont rien dans la colonne T : NB FNC
Je les ai compté avec les 1...
Macro à appliquer sur une Feuil2 vierge
Il n'est pas fait de mise en forme sur les en-têtes ni sur les groupes
Le groupe est identifié par sa tête de liste.
Sub Bouton2_Cliquer()
Dim i%, iLR%, k%, Arr(5)
iLR = Worksheets("Feuil1").Range("O" & Rows.Count).End(xlUp).Row
With Worksheets("Feuil2")
For i = 2 To 14 Step 6 'En têtes de colonnes
.Range(.Cells(1, i), .Cells(1, i + 4)).Borders.LineStyle = xlContinuous
.Cells(1, i) = Worksheets("Feuil1").Cells(15)
For k = 1 To 4
.Cells(1, i + k) = Worksheets("Feuil1").Cells(k + 18)
Next
Next
For i = 2 To iLR 'Décalage des groupes
Arr(0) = Worksheets("Feuil1").Cells(i, 15)
Arr(1) = Worksheets("Feuil1").Cells(i, 19)
Arr(2) = Worksheets("Feuil1").Cells(i, 20)
Arr(3) = Worksheets("Feuil1").Cells(i, 21)
Arr(4) = Worksheets("Feuil1").Cells(i, 22)
If Arr(2) > 1 Then
If Arr(1) > 20000 And Arr(3) < 0.85 Then
For k = 0 To 4: .Cells(i, 24 + k) = Arr(k): Next 'Groupe 1
ElseIf Arr(1) > 20000 And Arr(3) > 0.85 Then
For k = 0 To 4: .Cells(i, 30 + k) = Arr(k): Next 'Groupe 2
ElseIf Arr(1) < 20000 And Arr(3) < 0.85 Then
For k = 0 To 4: .Cells(i, 36 + k) = Arr(k): Next 'Groupe 3
ElseIf Arr(1) < 20000 And Arr(3) > 0.85 Then
For k = 0 To 4: .Cells(i, 42 + k) = Arr(k): Next 'Groupe 4
End If
Else 'Arr(2) = 1 + 3 vides
If Arr(1) > 20000 And Arr(3) < 0.85 Then
For k = 0 To 4: .Cells(i, 48 + k) = Arr(k): Next 'Groupe 5
ElseIf Arr(1) > 20000 And Arr(3) > 0.85 Then
For k = 0 To 4: .Cells(i, 54 + k) = Arr(k): Next 'Groupe 6
ElseIf Arr(1) < 20000 And Arr(3) < 0.85 Then
For k = 0 To 4: .Cells(i, 60 + k) = Arr(k): Next 'Groupe 7
ElseIf Arr(1) < 20000 And Arr(3) > 0.85 Then
For k = 0 To 4: .Cells(i, 66 + k) = Arr(k): Next 'Groupe 8
End If
End If
Next i
'Filtrage des vides
.Range("$X$1:$AB$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Range("$AD$1:$AH$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Range("$AJ$1:$AN$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Range("$AP$1:$AT$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Range("$AV$1:$AZ$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Range("$BB$1:$BF$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Range("$BH$1:$BL$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Range("$BN$1:$BR$" & iLR).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
'Copie vers les colonnes cibles
k = 2
.Cells(k, 1) = 1 'Groupe 1
iLR = .Range("X" & Rows.Count).End(xlUp).Row
.Range("$X$2:$AB$" & iLR).Copy .Cells(k, 2): k = k + iLR - 1
.Cells(k, 1) = 2 'Groupe 2
iLR = .Range("AD" & Rows.Count).End(xlUp).Row
.Range("$AD$2:$AH$" & iLR).Copy .Cells(k, 2): k = k + iLR - 1
.Cells(k, 1) = 3 'Groupe 3
iLR = .Range("AJ" & Rows.Count).End(xlUp).Row
.Range("$AJ$2:$AN$" & iLR).Copy .Cells(k, 2): k = 2
.Cells(k, 7) = 4 'Groupe 4
iLR = .Range("AP" & Rows.Count).End(xlUp).Row
.Range("$AP$2:$AT$" & iLR).Copy .Cells(k, 8): k = 2
.Cells(k, 13) = 5 'Groupe 5
iLR = .Range("AV" & Rows.Count).End(xlUp).Row
.Range("$AV$2:$AZ$" & iLR).Copy .Cells(k, 14): k = k + iLR - 1
.Cells(k, 13) = 6 'Groupe 6
iLR = .Range("BB" & Rows.Count).End(xlUp).Row
.Range("$BB$2:$BF$" & iLR).Copy .Cells(k, 14): k = k + iLR - 1
.Cells(k, 13) = 7 'Groupe 7
iLR = .Range("BH" & Rows.Count).End(xlUp).Row
.Range("$BH$2:$BL$" & iLR).Copy .Cells(k, 14): k = k + iLR - 1
.Cells(k, 13) = 8 'Groupe 8
iLR = .Range("BN" & Rows.Count).End(xlUp).Row
.Range("$BN$2:$BR$" & iLR).Copy .Cells(k, 14)
.Columns("X:BR").Delete 'Nettoyage
End With
End SubEDIT : La macro a été corrigée pour inclure les en-têtes.
Je n'ai pas ajouté la mise en forme pour la colonne des groupes : ça rendrait la macro confuse et 2 fois plus longue que celle-ci.
Pour 8 fusions à faire manuellement je trouve que le jeu n'en vaut pas la chandelle...
Mais si le cœur t'en dit ça se passe dans les lignes après :
'Copie vers les colonnes cibles...
Les fusions se font avant de passer au groupe suivant.
A+
Waaaooh !
Je lisais ca hier sur mon téléphone et j'avais la bouche grande ouverte !
Je te réponds à mon retour au bureau ce matin. C'est vraiment impressionant ! Je te remercie en tout cas pour ce travail magnifique !
Quand je vois un code comme ca, ca me remet à ma place de petit débutant-amateur !
C'est plus que parfait ! Je vais reprendre ton code ligne par ligne et essayer de le comprendre !
C'est du graaand Mendès en tout cas !
Merci beaucoup, c'est un peu léger pour le travail que tu as fais ... mais c'est hélàs mon seul moyen !
Bonne journée à toi,
Cdlt,
Floo73
Une dernière petite question :
Peux-tu m'expliquer la fonction de ces lignes ?
RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNoBonne journée,
Floo73
Bonjour,
Pas vu le retour...
RemoveDuplicate supprime les doublons (en l'occurrence elle supprime les vides dans chaque colonne)
ça compacte les données pour pouvoir les transférer en bloc vers leur emplacement définitif.
A+