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
| Sub test()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim F2 As Worksheet
Set F1 = Sheets("Feuil2")
Set F2 = Sheets("RESULTAT")
F2.Cells.ClearContents
Dim unique As New Collection
Dim i As Integer
On Error Resume Next
For Each cel In F1.Range("A2:A" & [A65000].End(xlUp).Row)
If F1.Cells(cel.Row, 2) <> 0 Then
unique.Add cel.Value, CStr(cel.Value)
End If
Next cel
F2.Cells(1, 1).Resize(1, 4) = Array("Acteur", "periode Debut", "Periode Fin", "Nombre de validation")
ligne = 2
On Error GoTo 0
For i = 1 To unique.Count
F2.Cells(ligne, 1) = unique(i)
ligne = ligne + 1
Next i
Dim derlig As Long
Dim lngNumLigne As Long
derlig = F2.Cells(Rows.Count, 1).End(xlUp).Row
For L = 2 To derlig
F2.Cells(L, 4) = WorksheetFunction.CountIfs(F1.Columns("A"), F2.Cells(L, 1), F1.Columns("C"), 1)
Next L
For J = 2 To derlig
F1.Range("A1:C" & derlig).AutoFilter Field:=1, Criteria1:=F2.Cells(J, 1)
Dim Lig As Long
Lig = F1.Range("A2:A" & derlig).SpecialCells(xlCellTypeVisible).Row
F2.Cells(J, 2) = F1.Cells(Lig, 2)
For Each cell In F1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
lngNumLigne = cell.Row
Next cell
F2.Cells(J, 3) = F1.Cells(lngNumLigne, 2)
F1.ShowAllData
Next J
Application.ScreenUpdating = True
End Sub |
Partager