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
| Sub CVisitesMedicales_Click()
'Déclaration des variables
Dim Mini As Integer, Maxi As Integer, AnneePlus, PF, DL_SF&, Nom, SF, i&, J&, L$, TB_L
'On borne les limites de recherche pour accélérer le traiement
Mini = -5: Maxi = 5
'On crée une boucle de consigne
Do
'Affichage de la Message Box informant des bornes de recherche
If AnneePlus Then MsgBox "Merci de mettre un entier compris entre " & Mini & " et " & Maxi
'Demande du nombre d'années suplémentaires à ajouter ou des années excédentaires à soustraire
AnneePlus = Application.InputBox("Ajouter un nombre d'année(s) supplémentaire(s)" & vbCr & "+ ou - sur l'année en cours", "ANNÉE SUPPLÉMENTAIRE VOULUE", Type:=1)
'Si fermeture de la Massage Box, fin du programme
If AnneePlus = "False" Then Exit Sub
'???
Loop Until AnneePlus = Fix(AnneePlus) And AnneePlus >= Mini And AnneePlus <= Maxi
'On pointe le classeur contenant la macro et la feuille cible afin de lui donner des instructions
With ThisWorkbook.Worksheets("VISITES MEDICALES")
'On interrompt l'affichage des calculs afin d'accélérer le traitement
Application.ScreenUpdating = False
'On affiche le message et l'année choisie pour l'exécution de la recherche
.Range("A1").Value = "VISITES MEDICALES " & Year(Date) + AnneePlus
'On pointe la plage d'affichage du futur tableau de synthèse
With .Range("C4:N16")
'On efface son contenu précédent
.Value = ""
'On enregistre la valeur de cette plage (?)
PF = .Value
'On pointe le classeur contenant la macro et la feuille source afin de lui donner des instructions
With Sheets("SUIVI MEDICAL")
'On définit la dernière ligne renseignée
DL_SF = .Cells(Rows.Count, 1).End(xlUp).Row
'Création d 'un tableau Nom pour les noms et prénoms / indice 1
Nom = .Range("A5:B" & DL_SF).Value
'Création d 'un tableau SF pour les dates de visites à rechercher / indice 1
SF = .Range("I5:U" & DL_SF).Value
'On Boucle les colonnes du tableau SF depuis le plus petit indice jusqu'au plus grand
For J = 1 To UBound(SF, 2)
'On Boucle les lignes du tableau SF depuis le plus petit indice jusqu'au plus grand
For i = 1 To UBound(SF)
'Si la cellule intersection entre ligne et colonne du tableau n'est pas vide, alors...
If SF(i, J) > "" Then
'Si la date contenue dans cette cellule fait partie de l'année recherchée (année en cours + nombre d'année en + ou en -)
If Year(SF(i, J)) = Year(Date) + AnneePlus Then
'On remplit le tableau cible par les arguments trouvés, classés par mois des dates sélectionnées, on affiche les NOMS et Prénoms des salariés dans la cellule correspondante, concaténnés si besoin est
'besoin d'un peu plus d'explications ici!
PF(J, Month(SF(i, J))) = IIf(PF(J, Month(SF(i, J))) = "", Nom(i, 1) & " " & LCase(Nom(i, 2)), PF(J, Month(SF(i, J))) & vbCr & " - " & Nom(i, 1) & " " & LCase(Nom(i, 2)))
'Récupération des lignes incriminées pour la mise en forme/couleur dans VISITES MEDICALES
'besoin d'un peu plus d'explications ici!
If Not L Like "*" & J + 3 & "*" Then L = L & " " & J + 3
End If
End If
Next
Next
End With
'On colle le tableau dans sa sélection finale
.Value = PF
'on ajuste la hauteur des lignes
.Rows.AutoFit
End With
'Réinitialisation de la mise en forme/couleur de A4 à B20
With .Range("A4:B20")
.Interior.ColorIndex = xlNone
.Font.Bold = False
.Font.Color = 1
End With
TB_L = Split(Trim(L), " ")
For i = LBound(TB_L) To UBound(TB_L) 'Mise en forme/couleur de A4 à B 20 - PS pas bien les cellules fusionnées, en général on les évite ;) mais bon ici c'est pas très grave ;)
For J = 1 To 2
With .Cells(TB_L(i), J)
If .MergeArea.Count > 1 Then
.MergeArea.Interior.ColorIndex = 6
.MergeArea.Font.Bold = True
If J > 3 Then .MergeArea.Font.ColorIndex = 10
Else
.Interior.ColorIndex = 6
.Font.Bold = True
If J > 3 Then .Font.ColorIndex = 10
End If
End With
Next
Next
Application.ScreenUpdating = True
End With
End Sub |
Partager