AW: Zweit häufigste Zahl in VBA?
06.12.2009 13:21:09
Nepumuk
Servus Sepp,
konnte mir natürlich den Härtetest nicht verkneifen und habe versucht diese Tabelle auszuwerten:
| A | B | C | D |
1 | 1 | 1 | 1 | 1 |
2 | 2 | 2 | 2 | 2 |
3 | 3 | 3 | 3 | 3 |
4 | 4 | 4 | 4 | 4 |
5 | 5 | 5 | 5 | 5 |
6 | 6 | 6 | 6 | 6 |
7 | 7 | 7 | 7 | 7 |
8 | 7 | 6 | 6 | 6 |
9 | 7 | 9 | 9 | 9 |
10 | 10 | 10 | 10 | 10 |
11 | 11 | 11 | 11 | 11 |
12 | 12 | 12 | 12 | 12 |
13 | 13 | 13 | 13 | 13 |
14 | 14 | 14 | aaa | 14 |
15 | 15 | 15 | aaa | 15 |
16 | 16 | 16 | aaa | 16 |
17 | 17 | 17 | 17 | #NV |
18 | 18 | 18 | 18 | #NV |
19 | 19 | 19 | 19 | 19 |
20 | 20 | 20 | 20 | 20 |
Geht nicht. :-(
Mit reinem VBA kein Problem :-)
Option Explicit
Public Sub Beispiel()
Dim vntArray As Variant, vntItem As Variant
Dim lngCounter() As Long
With Tabelle1
'Bereich A1 - D20
vntArray = Range(.Cells(1, 1), .Cells(20, 4)).Value2
End With
Redim lngCounter(1 To 2, 1 To 1)
For Each vntItem In vntArray
If IsNumeric(vntItem) And Not IsEmpty(vntItem) Then
If UBound(lngCounter, 2) < vntItem Then _
Redim Preserve lngCounter(1 To 2, 1 To vntItem)
lngCounter(1, vntItem) = lngCounter(1, vntItem) + 1
lngCounter(2, vntItem) = vntItem
End If
Next
Call QuickSort(LBound(lngCounter, 2), UBound(lngCounter, 2), lngCounter)
MsgBox lngCounter(2, 2)
End Sub
Private Sub QuickSort(lngLBound As Long, lngUBound As Long, lngArray() As Long)
Dim lngIndex1 As Long, lngIndex2 As Long, lngColumn As Long
Dim lngTemp As Long, lngBuffer As Long
lngIndex1 = lngLBound
lngIndex2 = lngUBound
lngBuffer = lngArray(1, Fix(lngLBound + lngUBound) / 2)
Do
Do While lngArray(1, lngIndex1) > lngBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While lngBuffer > lngArray(1, lngIndex2)
lngIndex2 = lngIndex2 - 1
Loop
If lngIndex1 <= lngIndex2 Then
For lngColumn = 1 To 2
lngTemp = lngArray(lngColumn, lngIndex1)
lngArray(lngColumn, lngIndex1) = lngArray(lngColumn, lngIndex2)
lngArray(lngColumn, lngIndex2) = lngTemp
Next
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngLBound < lngIndex2 Then Call QuickSort(lngLBound, lngIndex2, lngArray())
If lngIndex1 < lngUBound Then Call QuickSort(lngIndex1, lngUBound, lngArray())
End Sub
Schönen Sonntag noch
Nepumuk