Discussion :

[will-1981]

Bonjour,

J'ai créé une macro qui fonctionne bien. elle me permet de synthétiser le nombre de personne par activité et ceux ci par jour sur toute l'année.

J'ai mis une demande de date de démarrage pour alléger le calcul et ce qu'il y a dans le passée par rapport à la date du jour nous intéresse peu mais ayant encore 5.5 mois à faire avant la fin 2014 ça fait beaucoup de calcul. En l’occurrence 2368 cellules à remplir soit d'un 0 soit du nombre de personne concernée. Car en tout j'ai 16 activités différentes et j'ai un planning de 280 personnes donc 280 lignes à analyser. (pour le moment)

En clair, elle prend 1 mn pour 5.5 mois. Mais je voudrais ramener ça à quelques secondes. car la zone d'affectation des activités est régi par un _change.

Vous avez une suggestion ?

Merci pour votre aide,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
 
Sub calculEFF()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim wsPP As Worksheet, Activite As String, Nbrediag As String, date_deb As Date
 
Set wsPP = Sheets("Planning du personnel")
 
With wsPP
finlist = .Range("A1000").End(xlUp).Row
fincol = .Range("XFD5").End(xlToLeft).Column
 
date_deb = InputBox("Date ?", "Quelle sera la date de début du calcul", Date)
 
'recherche de la premiere colonne de départ et de la colonne de fin
c = 6
For c = 6 To fincol
    If .Cells(4, c) = date_deb Then
        coldep = c
        Exit For
    End If
Next
 
'demarrage du calcul à la date donnée précédement
i = 7
e = 24
Effectif1 = 0
Effectif2 = 0
Nbrediag = 0
cpteur = 0
 
cpteur = 0
For c = coldep To fincol
    For i = 7 To 21
        'determination du nombre de personne suivant l'activté renseigné dans la colonne D
        Activite = .Cells(i, 4)
            For e = 24 To finlist
               If .Cells(e, c).Borders(xlDiagonalUp).LineStyle = xlContinuous And .Cells(e, c).Value = Activite Then
                   Nbrediag = Nbrediag + 1
               End If
            Next e
         'Compte le nombre de personne présente et déduit les 1/2 journée
            Effectif1 = WorksheetFunction.CountIf(.Columns(c), Activite)
            cpteur = cpteur + Effectif1
 
        'determination du nombre de personne suivant l'activté renseigné dans la colonne D si non vide
        If .Cells(i, 5) <> "" Then
            Activite = .Cells(i, 5)
            For e = 24 To finlist
               If .Cells(e, c).Borders(xlDiagonalUp).LineStyle = xlContinuous And .Cells(e, c).Value = Activite Then
                   Nbrediag = Nbrediag + 1
               End If
            Next e
            Effectif2 = WorksheetFunction.CountIf(.Columns(c), Activite)
            cpteur = cpteur + Effectif2
        End If
        'compte le nombre d'absent + les 1/2 journée
        If Activite = "Abs" Then
            valeur = WorksheetFunction.CountIf(.Columns(c), Activite) + Nbrediag / 2
        Else 'Compte le nombre de personne présente et déduit les 1/2 journées
            valeur = Effectif1 + Effectif2 - Nbrediag / 2
        End If
        If valeur <> Int(valeur) Then
            .Cells(i, c) = valeur
            .Cells(i, c).NumberFormat = "0.0"
        End If
 
        .Columns(c).EntireColumn.AutoFit
        Effectif1 = 0
        Effectif2 = 0
        Nbrediag = 0
        valeur = 0
    Next i
 
    'Nombre de personne non déterminer par des activités courantes hormis les samedis sans activité (PA)
    NbrePA = WorksheetFunction.CountIf(.Range(.Cells(25, c), .Cells(finlist, c)), "PA")
    valeur = WorksheetFunction.CountA(.Range(.Cells(25, c), .Cells(finlist, c))) - cpteur - NbrePA
    If valeur <> Int(valeur) Then
        .Cells(22, c) = valeur
        .Cells(22, c).NumberFormat = "0.0"
    End If
    valeur = 0
    cpteur = 0
    .Columns(c).EntireColumn.AutoFit
Next c
 
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub