Je passais que tu avais compris que tes macros n'ont ni queue ni tête.
à commencer par la macro transfert :
Je t'avais signalé déjà qu'elle commence par :
Set plage = Selection
Comme il n'y a aucune sélection d'effectuée elle commence n'importe ou : A1, Q26... tout est bon à prendre !
Bon ça ne l'empêche pas de démarrer quand même... mais dès la ligne suivante :
plg.PasteSpecial xlPasteValues
...tu as la Function SOMME_SI_COULEUR
...qui se met en branle et comme elle parcourt les 1152 cellules de la PlageSomme : il lui faut, on va dire un certain temps !
Ensuite un peu plus loin la macro "transfert" va travailler sur :
For Each Cel In .Range("a3:a1152"
donc relancer à chaque fois la Function SOMME_SI_COULEUR
...et comme elle parcourt les 1152 cellules de la PlageSomme : il lui faut cette fois un certain temps multiplié par 1150.
Si tu multiple ça par le nombre de seconde qui passent pendant "un certain temps" ça doit faire plus ou moins 20 minutes...
Après tout dépend de la vélocité de ton PC... S'il est un peu surbooké ça peu faire 1/2 heure s'il est jeune et musclé tu peut peut être gagner 5 minutes ! Mébon...
Alors moi je sais pas :
Vu que je sais pas ce que tu veux transférer ni ou...
Vu que je ne sais pas à quoi corresponde les couleurs (et je ne veux pas le savoir !)
Je ne peux te donner qu'un conseil : Laisse tomber ton arbre de Noel et toutes ces couleurs et surtout cette fonction ALAKON et pour le transfert tu fais une colonne "Joyeux Noël" disons dans la colonne O de ta Feuille "Suivi de Prod" ou tu mettra des indices de couleurs qui seront affectés par une Mise en Forme Conditionnelle.
Comme ça t'auras plus besoin de compter des couleurs sur 1150 lignes à la fois mais tu pourras utiliser une formule classique ou tu compteras sur la colonne O
Bon la grosse colère étant passée... Tu peux aussi essayer de mieux définir "sélection" et puis tu rajoutes :
Sub tranfert()
Dim derlig&, num&, sh As Worksheet, shc As Worksheet
Dim plage As Range, plg As Range, Cel As Range
Application.ScreenUpdating = False
Set sh = Sheets("Suivi de production")
Set shc = Sheets("Suivi de commande")
Set plage = Selection
plage.Copy
Application.Calculation = xlCalculationManual '********ligne à rajouter
Set plg = sh.Range("c" & Rows.Count).End(3)(2)
plg.PasteSpecial xlPasteValues
Application.CutCopyMode = 0
With sh
derlig = .Range("c" & Rows.Count).End(xlUp).Row
x = .Range("a" & Rows.Count).End(xlUp).Row + 1
num = 0
.Range(.Cells(x, 1), .Cells(derlig, 1)) = Date + 1
For Each Cel In .Range("a3:a" & derlig)
If Cel = Cel.Offset(-1, 0) Then
num = num + 1
Cel.Offset(0, 1) = num
Else
num = 1
Cel.Offset(0, 1) = num
End If
Next Cel
End With
Application.Goto sh.Range("a" & derlig)
shc.Activate
plage.EntireRow.Delete
Application.Calculation = xlAutomatic '****************ligne à rajouter
End Sub
Mais je ne suis pas certain que ça fera le job vu que je ne peux pas tester. (Je ne sais pas ce que tu veux transférer...)
A+