Indicare numero con presenza decrescente

---

ti direi

---

=INDICE(AM$3:AM$17;CONFRONTA(GRANDE(FREQUENZA(AM$3:AM$17;AM$3:AM$17);RIF.RIGA(A1));FREQUENZA(AM$3:AM$17;AM$3:AM$17);0))

---

matriciale

ma hai troppi doppioni che non vengono letti

---

Option Explicit
Sub Macro_col_creatore()
Dim cont As String
Dim i As Long
Dim cBB As Long
cBB = 54
Dim Nriga As Long

For i = 39 To 50
Range(Cells(3, i), Cells(17, i)).Select
Selection.Copy
Cells(3, cBB).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range(Cells(2, cBB), Cells(17, cBB)).RemoveDuplicates Columns:=1, Header:= _
xlYes

Nriga = Cells(Rows.Count, cBB).End(xlUp).Row + 1 ''dimenticato
Cells(3, cBB + 1).Select
cont = "=COUNTIF(R3C" & i & ":R17C" & i & ",RC[-1])"
ActiveCell.FormulaR1C1 = cont
Selection.AutoFill Destination:=Range(Cells(3, cBB + 1), Cells(Nriga, cBB + 1)), Type:=xlFillDefault
Range(Cells(3, cBB), Cells(Nriga, cBB + 1)).Select
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Add Key:=Cells(3, cBB + 1), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Helper").Sort
.SetRange Range(Cells(2, cBB), Cells(Nriga, cBB + 1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Add Key:=Range(Cells(3, cBB + 1), Cells(Nriga, cBB + 1)) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Helper").Sort
.SetRange Range(Cells(2, cBB), Cells(Nriga, cBB + 1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range(Cells(8, cBB), Cells(Nriga, cBB + 1)).ClearContents
cBB = cBB + 2
Next i
End Sub

---

---

' Procedure : uModa
' Author : Scossa
' Date : 26/02/2012
' Purpose :
'---------------------------------------------------------------------------------------


Public Function uModa2(ByVal rng As Range, Optional ByVal nPos As Integer = 1) As Variant
Dim nCnt As Long
Dim nMax As Long
Dim cDati As New Collection
Dim cMax As New Collection
Dim cOrdine As New Collection
Dim cella As Range
Dim vDato As Variant
Dim aDati() As Long
Dim vRetVal As Variant
Dim j As Integer

On Error Resume Next
For Each cella In rng
With cella
nCnt = Application.WorksheetFunction.CountIf(rng, .Value)
cDati.Add Array(.Value, nCnt), CStr(.Value)
cMax.Add nCnt, CStr(nCnt)
End With
Next
On Error GoTo 0
j = 0
ReDim aDati(1 To cMax.Count)
For Each vDato In cMax
j = j + 1
aDati(j) = vDato
Next

nPos = Application.WorksheetFunction.Max(nPos, 1)
nPos = Application.WorksheetFunction.Min(nPos, cDati.Count)
'eventualemente togliere il commento alla riga sotto
'nPos = Application.WorksheetFunction.Min(nPos, cMax.Count)
nMax = Application.WorksheetFunction.Large(aDati, nPos)

On Error Resume Next
For Each vDato In cDati
If vDato(1) = nMax Then
vRetVal = vRetVal & "; " & vDato(0)
Else
cOrdine.Add vDato, CStr(vDato(0))
End If
Next
vRetVal = Mid(vRetVal, 3)
cOrdine.Add Array(vRetVal, nMax), CStr(vRetVal)
On Error GoTo 0

For Each vDato In cOrdine
If vDato(1) = nMax Then
vRetVal = vDato(0)
End If
Next

If IsNumeric(vRetVal) Then vRetVal = vRetVal * 1

uModa2 = Array(vRetVal, nMax)

End Function

---

---

=SE.ERRORE(uModa2($AM$3:$AM$17;BA3);"")

---

---

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("AM3:AX17")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim cont As String
Dim i As Long
Dim cBB As Long
cBB = 54
Dim Nriga As Long

For i = 39 To 50
Range(Cells(3, i), Cells(17, i)).Select
Selection.Copy
Cells(3, cBB).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range(Cells(2, cBB), Cells(17, cBB)).RemoveDuplicates Columns:=1, Header:= _
xlYes

Nriga = Cells(Rows.Count, cBB).End(xlUp).Row + 1
Cells(3, cBB + 1).Select
cont = "=COUNTIF(R3C" & i & ":R17C" & i & ",RC[-1])"
ActiveCell.FormulaR1C1 = cont
Selection.AutoFill Destination:=Range(Cells(3, cBB + 1), Cells(Nriga, cBB + 1)), Type:=xlFillDefault
Range(Cells(3, cBB), Cells(Nriga, cBB + 1)).Select
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Add Key:=Cells(3, cBB + 1), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Helper").Sort
.SetRange Range(Cells(2, cBB), Cells(Nriga, cBB + 1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Helper").Sort.SortFields.Add Key:=Range(Cells(3, cBB + 1), Cells(Nriga, cBB + 1)) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Helper").Sort
.SetRange Range(Cells(2, cBB), Cells(Nriga, cBB + 1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range(Cells(8, cBB), Cells(Nriga, cBB + 1)).ClearContents
cBB = cBB + 2
Next i
Application.ScreenUpdating = True
Target.Select
End Sub

---