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
91
| Sub AfficherLesPrestations()
Application.ScreenUpdating = False
' Ouvre la feuille ("Prestations"), la rend visible,la selectionne et se positionne sur la cellule ("A1")
With Sheets("Prestations")
.Select
.cells(1, 1).Select
End With
Dim annee As Integer, Compteur As Integer, Debut As Integer, Fin As Integer
Dim Maplage As Range, Cellule As Range
annee = Frm_ReleveAnnuel.ComboBox1.Value
' Recherche la première cellule contenant Annee
cells.Find(annee, ActiveCell, xlValues, xlPart, xlByRows, xlNext, False, True).Select
'cells.Find("01/" & mois & "/" & annee, ActiveCell, xlValues, xlPart, xlByRows, xlNext, False, True).Select
' Recherche sur une plage de 365 jours ou (366 jours si l'année bisextille)
' Début de la plage
Debut = ActiveCell.Row - 1
' Fin de la plage
Fin = Debut + 364 + IIf((annee Mod 4 = 0 And annee Mod 100 <> 0) Or annee Mod 400 = 0, 1, 0)
Dim Plage As Range
Dim Tableau(), Resultat() As String
Dim i As Integer, j As Integer, m As Integer
Dim Un As Collection
Dim Doublons As String
Set Un = New Collection
'La plage de cellules (sur une colonne) à tester
'Set Plage = Range("A1:A" & Range("A65536").End(xlUp).Row)
Set Plage = Range("I" & Debut & ":I" & Fin)
Tableau = Plage.Value
On Error Resume Next
'boucle sur la plage à tester
For i = 1 To Plage.Count - 1
ReDim Preserve Resultat(2, m + 1)
'Utilise une collection pour rechercher les doublons
'(i, 0): les collections acceptent les données uniques)
'(i, 1) : les collections n'acceptent pas les données uniques)
'Un.Add Tableau(i, 1), CStr(Tableau(i, 1))
Un.Add Tableau(i, 0), CStr(Tableau(i, 0))
'S'il y a une erreur (donc présence d'un doublon)
If Err <> 0 Then
'boucle sur le tableau des doublons pour vérifier s'il a déjà été identifié
For j = 1 To m + 1
'Si oui, on incrémente le compteur
If Resultat(1, j) = Tableau(i, 1) Then
'If Resultat(1, j) = Tableau(i, 1) Then
Resultat(2, j) = Resultat(2, j) + 1
Err.Clear
Exit For
End If
Next j
'Si non, on ajoute le doublon dans le tableau
If Err <> 0 Then
Resultat(1, m + 1) = Tableau(i, 1)
Resultat(2, m + 1) = 1
m = m + 1
Err.Clear
End If
End If
Next i
'----- Affiche la liste et le nombre de doublons --------
For j = 1 To m
Doublons = Doublons & Resultat(1, j) & " --> " & _
Resultat(2, j) & vbCrLf
With Frm_ReleveAnnuel
.Controls("Lbl_P" & j).Caption = Resultat(1, j)
.Controls("Lbl_J" & j).Caption = Resultat(2, j)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
??? Ici : A chaque fois que .Controls("Lbl_P" & j).Caption = Range("I" & Debut & ":I" & Fin)
additionner la cellule ("AB")
et ajouter le resultat dans :
.Controls("Lbl_H" & j).Caption = Resultat(2, j)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End With
Next j
Set Un = Nothing
Application.ScreenUpdating = True
End Sub |
Parcourir une plage selon une condition
Répondre avec citation
Partager