combien de fois de suite

[COLOR="DarkSlateGray"][B]Sub toto()
         [COLOR="SeaGreen"]'4 Pluviôse CCXVIII
         'ROGER2327 fecit.
         '[/COLOR]
Dim pDat As Object, oCol As Range, oCel As Range
Dim oNum As New Collection, oVar As New Collection
Dim oCpt, i As Long, j As Long, n As Long
   Set pDat = Range("DATA") [COLOR="SeaGreen"]'Plage contenant les données.(B2:U46)[/COLOR]
   With Range("SORT") [COLOR="SeaGreen"]'Première cellule de résultat. (W2)[/COLOR]
      .CurrentRegion.Offset(1, 0).ClearContents
      Application.ScreenUpdating = False
      On Error Resume Next
      For Each oCol In pDat.Columns
         For Each oCel In oCol.Cells
            oNum.Add oCel.Value
            oVar.Add oCel.Value, CStr(oCel.Value)
         Next oCel
      Next oCol
      On Error GoTo 0
      Set pDat = Nothing
      ReDim oCpt(1 To oVar.Count, 1 To 2) As Variant
      For i = 1 To oVar.Count
         oCpt(i, 1) = oVar(i)
         n = 0
         For j = 1 To oNum.Count
            If oNum(j) = oVar(i) Then
               n = n + 1
            Else
               If n > 1 Then
                  If n > UBound(oCpt, 2) Then ReDim Preserve oCpt(1 To oVar.Count, 1 To n)
                  oCpt(i, n) = oCpt(i, n) + 1
               End If
               n = 0
            End If
         Next j
      Next i
      Set oNum = Nothing
      Set oVar = Nothing
      With .Resize(UBound(oCpt, 1), UBound(oCpt, 2))
         .Value = oCpt
         .Sort Key1:=Range("SORT"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      End With
      Application.ScreenUpdating = True
   End With
End Sub[/B][/COLOR]

[COLOR="DarkSlateGray"][B]Sub toto2()
         [COLOR="SeaGreen"]'5 Pluviôse CCXVIII
         'ROGER2327 fecit.
         '[/COLOR]
Dim pDat As Object, oCel As Range
Dim oVar As New Collection
Dim oCpt, i As Long, j As Long, k As Long, n As Long, tf As Boolean
   Set pDat = Range("DATA")[COLOR="SeaGreen"] 'Plage contenant les données.(B2:U46)[/COLOR]
   With Range("SORT") [COLOR="SeaGreen"]'Première cellule de résultat. (W2)[/COLOR]
      .CurrentRegion.Offset(1, 0).ClearContents
      Application.ScreenUpdating = False
      On Error Resume Next
      For Each oCel In pDat.Cells
         oVar.Add oCel.Value, CStr(oCel.Value)
      Next oCel
      On Error GoTo 0
      ReDim oCpt(1 To oVar.Count, 1 To 2) As Variant
      For i = 1 To oVar.Count
         oCpt(i, 1) = oVar(i)
         n = 0
         For j = 1 To pDat.Rows.Count
            tf = False
            For k = 1 To pDat.Columns.Count
               If pDat.Cells(j, k).Value = oVar(i) Then
                  tf = True
                  n = n + 1
                  Exit For
               End If
            Next k
            If Not tf Or j = pDat.Rows.Count Then
               If n > 1 Then
                  If n > UBound(oCpt, 2) Then ReDim Preserve oCpt(1 To oVar.Count, 1 To n)
                  oCpt(i, n) = oCpt(i, n) + 1
               End If
               tf = False
               n = 0
            End If
         Next j
      Next i
      Set oVar = Nothing
      With .Resize(UBound(oCpt, 1), UBound(oCpt, 2))
         .Value = oCpt
         .Sort Key1:=Range("SORT"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      End With
      Application.ScreenUpdating = True
   End With
End Sub[/B][/COLOR]