Oui.Avez vous d'autres idées pour optimiser le code ?
Option Explicit
Sub ActualisationActiviteQuotidenne()
Call DES
Call TypeTrn
Range("A7:AI65536").Clear
Dim TrnCode As Object
Dim cel As Object
Dim PlanTp As Object
Dim lg As Integer
Dim NomPlanning As String
Dim j As Integer, k As Integer, l As Integer 'pour boucle
Dim Vartemp As Integer
Dim ws As Object
Set ws = ActiveWorkbook.ActiveSheet
'determination de la zone de recherche des codes tournées
Set TrnCode = Worksheets(F_Trn).Range(Z_TrnColCode)
lg = PLActQuot
For Each cel In TrnCode
'si le code est le meme que la ligne precedente je passe à la ligne suivante
If cel.Value = cel.Offset(-1, 0).Value Or cel.Value = 0 Then GoTo suivant
If cel.Offset(0, 1) = TypeTrnRegul Then GoTo suivant 'supprimer cette ligne si on veut les regul d'heures
Vartemp = 0
'mise en place des données des colonnes A->D
ws.Cells(lg, 2) = cel.Offset(0, 1) 'type trn
ws.Cells(lg, 3) = cel.Offset(0, -1) 'lib trn
ws.Cells(lg, 4).FormulaLocal = "=SOMME(E" & lg & ":AI" & lg & ")"
'calcul par jour des données à reporter
For k = PCPlan To DCPlan Step 2
'Remonte la tournée prévue dans les planning
For j = 1 To 2
If j = 1 Then NomPlanning = "Planning " & Worksheets(F_Besoins).Range(Z_Grp1) Else NomPlanning = "Planning " & Worksheets(F_Besoins).Range(Z_Grp2)
Set PlanTp = Worksheets(NomPlanning)
For l = PLPlan To 3400 Step 6
If IsEmpty(PlanTp.Cells(l, 1)) = True Then Exit For
If UCase(PlanTp.Cells(l + 1, k)) = UCase(cel.Value) Then Vartemp = Vartemp + 1
Next l
Next j
ws.Cells(lg, k / 2 + 1) = Vartemp
'calcul de la couleur si le nb de tournée prevue est different du reel
If Weekday(ws.Cells(6, k / 2 + 1), 2) > 5 Then ws.Cells(lg, k / 2 + 1).Interior.ColorIndex = 37
If ws.Cells(lg, k / 2 + 1) <> cel.Offset(0, (Weekday(ws.Cells(PLActQuot - 1, k / 2 + 1), 2)) * 2 + 3) And ws.Cells(lg, 2) <> TypeTrnAbsNonRem And ws.Cells(lg, 2) <> TypeTrnAbsRem Then
If ws.Cells(lg, k / 2 + 1) = 0 Then ws.Cells(lg, k / 2 + 1).Interior.ColorIndex = 3
If ws.Cells(lg, k / 2 + 1) > cel.Offset(0, (Weekday(ws.Cells(PLActQuot - 1, k / 2 + 1), 2)) * 2 + 3) Then ws.Cells(lg, k / 2 + 1).Interior.ColorIndex = 46
If ws.Cells(lg, k / 2 + 1) < cel.Offset(0, (Weekday(ws.Cells(PLActQuot - 1, k / 2 + 1), 2)) * 2 + 3) And ws.Cells(lg, k / 2 + 1) <> 0 Then ws.Cells(lg, k / 2 + 1).Interior.ColorIndex = 44
End If
Vartemp = 0
'grise la cellule si jour ferie
If Application.WorksheetFunction.CountIf(Worksheets(F_Parametres).Range("A:A"), ws.Cells(PLActQuot - 1, k / 2 + 1)) > 0 Then ws.Cells(lg, k / 2 + 1).Interior.Color = RGB(204, 204, 204)
Next k
lg = lg + 1
suivant:
Next cel
'mef tab
Range("B6").Select
Selection.CurrentRegion.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
Call ACT
End Sub
Sub DES()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Sub ACT()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Sub TypeTrn()
TypeTrnAbsRem = Worksheets(F_Parametres).Cells(2, 4)
TypeTrnAbsNonRem = Worksheets(F_Parametres).Cells(3, 4)
TypeTrnRegul = Worksheets(F_Parametres).Cells(4, 4)
TypeTrnExploit = Worksheets(F_Parametres).Cells(5, 4)
End Sub
Sub maContribution()
'mef tab
With Range("B6").CurrentRegion
.HorizontalAlignment = -4108: .VerticalAlignment = -4108
.Borders.LineStyle = 1
End With
End Sub
Merci de ton partage.Quand j'aurais fini le developpement je mettrais en ligne le nouveau pour ceux que ca pourrais interresser plus tard
Cordialement
Crisky
Sub ActualisationActiviteQuotidenne()
Dim Lg As Integer, Col As Integer, Plan7(), Plan8(), Tb(), Result(), wb, ix, m, n, Jour
ReDim Result(1 To 300, 1 To 50)
Call DES
'report des données dans les variables tableaux
Plan7 = Feuil07.Range(Feuil07.Cells(1, 1), Feuil07.Cells(3400, 68)).Value
Plan8 = Feuil08.Range(Feuil08.Cells(1, 1), Feuil08.Cells(3400, 68)).Value
Tb = Feuil04.Range(Feuil04.Cells(6, 1), Feuil04.Cells(500, 19)).Value
'effacement des anciennes données de la feuille
Set wb = ActiveWorkbook.Worksheets(F_ActQuot): wb.Range("B7:AI306").Clear
'boucle de traitement des données du tableau Tb(tournées)
ix = 1
Call TypeTrn
For i = 1 To 300
's'il n'y a pas de tournée sur la ligne fin de traitement du tableau tournée
If Tb(i, 1) = Empty Then Exit For
'si la tournée = tournée précédente passage à la ligne suivante
If i <> 1 Then
If Tb(i, 1) = Tb(i - 1, 1) Or Tb(i, 3) = TypeTrnRegul Then
ix = ix - 1
GoTo suite
End If
End If
'affectation des données ds la tableau resultat
Result(ix, 1) = Tb(i, 3) 'type trn
Result(ix, 2) = Tb(i, 1) 'libellé trn
'boucle de traitement des données
'boucle sur les jours du mois
For k = 8 To 68 Step 2
Vartemp = Empty
'boucle sur chacun sur les 2 plannings
For l = 1 To 2
'boucle sur les lignes du planning
For j = PLPlan To 3396 Step 6
'si le code trn de planning = code trn de trn incrmentation
'traitement différent suivant le planning de la boucle
If l = 1 Then
If UCase(Plan7(j + 2, k)) = UCase(Tb(i, 2)) Then Vartemp = Vartemp + 1
Else
If UCase(Plan8(j + 2, k)) = UCase(Tb(i, 2)) Then Vartemp = Vartemp + 1
End If
Next j
Next l
'si vartemp n'est pas vide alors j'affiche result =vartemp sinon vide : traitement obligatoire sinon il y a des # dans le report des cellules
If Vartemp <> Empty Then Result(ix, Int(k / 2)) = Vartemp Else Result(ix, Int(k / 2)) = Empty
Next k
'calcul de la somme des codes trn du mois
For n = 4 To 34
If Result(ix, n) <> Empty Then Result(ix, 3) = Result(ix, n) + Result(ix, 3)
Next n
suite:
ix = ix + 1
Next i
ecart = i - ix
'report de la variable tableau ds la feuille
wb.Range("B7:AI306") = Result
'mise en forme
n = 1
DateMois = Worksheets(F_ActQuot).Cells(6, 5).Value
For m = 4 To 34
Jour = 5 + Weekday(DateMois - (4 - m), vbMonday) * 2
Set cel = Worksheets(F_Parametres).Range(Z_Param_JF).Find(DateMois - (4 - m), , xlValues, xlWhole)
Do While Result(n, 1) <> Empty
If Not cel Is Nothing Then
Worksheets(F_ActQuot).Cells(n + PLActQuot - 1, m + 1).Interior.Color = RGB(204, 204, 204)
Else
If UCase(Result(n, m)) <> UCase(Tb(n + ecart, Jour)) And Result(n, 1) = TypeTrnExploit Then
If Result(n, m) > Tb(n + ecart, Jour) Then Worksheets(F_ActQuot).Cells(n + PLActQuot - 1, m + 1).Interior.ColorIndex = 46
If Result(n, m) < Tb(n + ecart, Jour) And Result(n, m) > 0 Then Worksheets(F_ActQuot).Cells(n + PLActQuot - 1, m + 1).Interior.ColorIndex = 44
If Result(n, m) < Tb(n + ecart, Jour) And Result(n, m) = Empty Then Worksheets(F_ActQuot).Cells(n + PLActQuot - 1, m + 1).Interior.ColorIndex = 3
Else
If Weekday(DateMois - (4 - m), vbMonday) > 5 Then Worksheets(F_ActQuot).Cells(n + PLActQuot - 1, m + 1).Interior.ColorIndex = 37
End If
End If
n = n + 1
Loop
n = 1
Next m
With wb.Range("B7").CurrentRegion
.HorizontalAlignment = -4108: .VerticalAlignment = -4108
.Borders.LineStyle = 1
End With
Call ACT
End Sub