Zelleninhalt auslesen

29/07/2010 - 09:03 von Jan-Thomas Kühnert | Report spam
Hallo,

ich addiere in Zellen jeweils eine unterschiedliche Anzahl immer
gleicher Zahlen (Preise), wie z. B.

=6,50+22,50+4,90+41,70+22,50+12,50+41,70

Nun möchte ich nachtràglich diesen Inhalt auslesen und auswerten. Ziel
der Übung ist eine Übersicht, welcher Preis wie oft vorkommt. Ich würde
dabei gern darauf verzichten, die zu suchenden Preise vorzugeben...

Ich hàtte also gern folgendes:
6,50 1
22,50 2
4,90 1
41,70 2

Geht so etwas?

Gruß,
Thomas
 

Lesen sie die antworten

#1 Andreas Killer
29/07/2010 - 16:05 | Warnen spam
Am 29.07.2010 09:03, schrieb Jan-Thomas Kühnert:

=6,50+22,50+4,90+41,70+22,50+12,50+41,70

Nun möchte ich nachtràglich diesen Inhalt auslesen und auswerten. Ziel
der Übung ist eine Übersicht, welcher Preis wie oft vorkommt. Ich
würde dabei gern darauf verzichten, die zu suchenden Preise vorzugeben...


Auf was für Ideen man doch kommen kann um sich das Leben schwer zu
machen... :-))

A1 =6,5+22,5+4,9+41,7+22,5+12,5+41,7
B1:C5 {=ZàhleFormelZahlen(A1)}

Die Matrixformel muss mind. soweit eingegeben werden das es für die
Ausgabe reicht.

Andreas.

Option Explicit

Function ZàhleFormelZahlen(Bereich As Range, _
Optional ByVal ClearUnusedSpaceValue) As Variant
Dim Dict As Object 'New Dictionary
Dim I As Long
Dim R As Range
Dim Data, Keys, Items

Set Dict = CreateObject("Scripting.Dictionary")

'Überhàngig eingegebene Bereiche vordefiniert löschen
If IsMissing(ClearUnusedSpaceValue) Then _
ClearUnusedSpaceValue = CVErr(xlErrNA)

'Durchlaufe alle Zellen
For Each R In Bereich
'Splitte Formel nach +
Data = Split(R.Formula, "+")
'Durchlaufe Werte
For I = 0 To UBound(Data)
'Das führende = entfernen
If Left$(Data(I), 1) = "=" Then Data(I) = Mid$(Data(I), 2)
'Evt. Leerzeichen entfernen
Data(I) = Trim$(Data(I))
'Is es eine Zahl?
If IsNumeric(Data(I)) Then
'Schon gehabt?
If Dict.Exists(Data(I)) Then
'Ja, zàhlen
Dict.Item(Data(I)) = Dict.Item(Data(I)) + 1
Else
'Neu anlegen
Dict.Add Data(I), 1
End If
End If
Next
Next

'Ausgabebereich min. Eingabebereich
With Application.Caller
If .Rows.Count > Dict.Count Then
I = .Rows.Count
Else
I = Dict.Count
End If
End With
ReDim Data(1 To I, 1 To 2) As Variant

'Werte und Anzahl holen
Keys = Dict.Keys
Items = Dict.Items
'Daten eintragen
For I = 1 To Dict.Count
Data(I, 1) = Val(Keys(I - 1))
Data(I, 2) = Val(Items(I - 1))
Next
'Rest löschen
With Application.Caller
For I = I To .Rows.Count
Data(I, 1) = ClearUnusedSpaceValue
Data(I, 2) = ClearUnusedSpaceValue
Next
End With

'Ausgeben
ZàhleFormelZahlen = Data
End Function

Ähnliche fragen