Häufigkeit verschiedener Namen

Ich bin trotzdem erstaunt auf was für interesant Lösungen ich hier stoße.

Ich möchte mich schonmal bei allen bedanken die Zeit und Grips investiert haben um mir zu helfen.

Ingo

Die Formel ist ausgezeichnet, hat auch nur ne 10 sek gebraucht bis alle Werte ermittelt waren.
Kannst Du mir nochmal helfen?
Ich möchte noch das die Auswertung nicht zwische Gross und Kleinschreibung unterscheidet. Wie es in der Übersichtsspalte ( also CV) dargestellt wir ist mir dann auch egal.
Außerdem habe ich festgestellt das in einigen Zellen vor den ersten Buchstaben ein leer Zeichen ist. Auch hier wäre es gut wenn die Formel diese ignorieren würde.

Ich habe Deine Formel auch etwas erweitert und habe noch eine Frage zu dem Diagramm das erstell wird. wie kann ich unter jeden Balken den Namen schreiben lassen, zur Zeit wird nur der erste Name unter dem Diagramm geschrieben. Ich möchte aber nicht auf die farbigen Balken verzichten. Wenn ich alle Balken mit einer Datenreihe erstelle klappt es ja, aber alle Balben sind nur in einer Farbe.

Hier der jetzige Stand der Formel

Sub HaeufigkeitNamen()
Dim BlaNa As String, s As String
Dim fiR As Long, laR As Long, laRn As Long, anz As Long, i As Long
Dim x As Long
Dim y As Long
Dim o As Long
Dim z As Long
Dim summe As Variant
Application.ScreenUpdating = False
BlaNa = ActiveSheet.Name
laR = Cells(Rows.Count, 25).End(xlUp).Row
Sheets.Add
ActiveSheet.Move After:=Sheets(Sheets.Count)
Sheets(BlaNa).Range("Y2:Y" & laR).Copy
ActiveSheet.Range("Y2:Y" & laR).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("Y2:Y" & laR).Sort Key1:=Range("Y2"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
fiR = 1
Do While Not i >= laR
anz = 0
For i = fiR To laR
s = Cells(fiR, 25).Value
If Cells(i, 25).Value = s Then
anz = anz + 1
Else
laRn = Cells(Rows.Count, 100).End(xlUp).Row
Cells(laRn + 1, 100).Value = s
Cells(laRn + 1, 101).Value = anz
fiR = i
Exit For
End If
Next i
If i > laR Then Exit Do
Loop
laR = Cells(Rows.Count, 100).End(xlUp).Row
ActiveSheet.Range("CV2:CW" & laR).Copy
Sheets(BlaNa).Range("CV2:CW" & laR).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
Sheets(BlaNa).Select
Application.ScreenUpdating = True
Range("CV1").Select

'Bildet die Summe alles Namen
z = 2
Do Until IsEmpty(Cells(z, 101))
z = z + 1
Loop
For o = 2 To z
summe = summe + Cells(o, 101).Value
Next o
Cells(1, 100).Value = "Verantwortlich"
Cells(1, 101).Value = "Anzahl"
Cells(1, 102).Value = "Gesamt"
Cells(2, 102).Value = summe

'Diagramm wird erzeugt
Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Sheets(BlaNa).Range(Sheets(BlaNa).Cells(2, 100).Address & ":" & Sheets(BlaNa).Cells(laRn + 1, 101).Address), PlotBy _
:=xlColumns
ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False
ActiveChart.HasLegend = False

x = 1
For y = 1 To laRn - 1
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(x).Values = Sheets(BlaNa).Cells(x + 1, 101)
ActiveChart.SeriesCollection(x).Name = Sheets(BlaNa).Cells(x + 1, 100)
x = x + 1
Next y

ActiveChart.Location Where:=xlLocationAsNewSheet
With ActiveChart
.HasTitle = True
.ChartTitle.Text = "Gesamtübersicht aller Verursacher bei " & summe & " Schadmeldungen"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Verursacher"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Anzahl"
End With

Sheets(BlaNa).Select
Range("A1").Select

End Sub

Im voraus nochmal Danke für die investierte Zeit

Ingo

Ich habe mich in dem vorigen Beitrag nicht Korrekt ausgedrückt.
Bei den einzelnen Zellen mit dem Leerzeichen vor den Namen, möchte ich natürlich nicht das der komplette Name ignoriert wird sondern nur das Leerzeichen.

Außerdem nicht wundern in der Formel ist kein Fehler in der dritten Zeile unter dem Kommentar "'Diagramm wird erzeugt". Habe die Formel nur reinkopiert und nicht aufgepasst ob es mit der Länge hinhaut.

Müsste theoretisch so aussehen

ActiveChart.SetSourceData Source:=Sheets(BlaNa).Range(Sheets(BlaNa) _
.Cells(2, 100).Address & ":" & Sheets(BlaNa).Cells(laRn + 1, 101).Address), PlotBy _
:=xlColumns

Gruss
Ingo

Nachtrag 2
von: Ingo J.
Geschrieben am: 10.05.2002 - 10:49:52

Hi,

habe die Lösung für mein Problem mit der Groß/Kleinschreibung und dem Leerzeichen selbst gefunden

Habe folgende Formellösung eingefügt

For a = 2 To laR
Text = Cells(a, 25).Value ' Zeichenfolge initialisieren.
Trim = LTrim(Text) ' Trim = "<-Name "
Cells(a, 25).Value = Trim
Text = Cells(a, 25).Value
Groß = UCase(Text) ' Groß = " Grossbuchstaben"
Cells(a, 25).Value = Groß
Next a

ist wahrscheinlich nicht das non plus ultra, aber es funktioniert.
Auch stimmt die Formel vom Beitrag zuvor nicht mehr, habe noch einige Punkte modifiziert.

Nun habe ich trotzdem noch das Problem mit der Balkenbeschriftung unterhalb jedes Balkens im Diagramm

Würde mich freuen wenn mir jemand bei meinen letzten Problem helfen könnte

MfG
Ingo

Re: Nachtrag
von: WernerB.
Geschrieben am: 10.05.2002 - 18:41:30

Hallo Ingo,

Deine Wünsche betreffend Gross-/Kleinschreibung und Nichtberücksichtigung von führenden/abschließenden Leerzeichen (hatte ich auch ohne Deinen Nachtrag so verstanden) sind jetzt eingearbeitet.
Bei der Gelegenheit habe ich auch noch zwei kleinere Programmfehler entdeckt und eliminiert.

Option Explicit
Sub HaeufigkeitNamen()
Dim c As Range
Dim BlaNa As String, s As String
Dim fiR As Long, laR As Long, laRn As Long, anz As Long, i As Long
    Application.ScreenUpdating = False
    BlaNa = ActiveSheet.Name
    laR = Cells(Rows.Count, 25).End(xlUp).Row
    Sheets.Add
    ActiveSheet.Move After:=Sheets(Sheets.Count)
    Sheets(BlaNa).Range("Y2:Y" & laR).Copy
    ActiveSheet.Range("Y2:Y" & laR).PasteSpecial Paste:=xlValues, _
      Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    For Each c In Range("Y2:Y" & laR)
      c.Value = WorksheetFunction.Trim(c.Value)
      c.Value = LCase(c.Value)
      c.Value = WorksheetFunction.Proper(c.Value)
    Next c
    Range("Y2:Y" & laR).Sort Key1:=Range("Y2"), _
      Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
      MatchCase:=False, Orientation:=xlTopToBottom
    fiR = 2
    Do While Not i > laR
      anz = 0
      For i = fiR To laR + 1
        s = Cells(fiR, 25).Value
        If Cells(i, 25).Value = s Then
          anz = anz + 1
        Else
          laRn = Cells(Rows.Count, 100).End(xlUp).Row
          Cells(laRn + 1, 100).Value = s
          Cells(laRn + 1, 101).Value = anz
          fiR = i
          Exit For
        End If
      Next i
      If i > laR Then Exit Do
    Loop
    laR = Cells(Rows.Count, 100).End(xlUp).Row
    ActiveSheet.Range("CV2:CW" & laR).Copy
    Sheets(BlaNa).Range("CV2:CW" & laR).PasteSpecial Paste:=xlValues, _
      Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    Sheets(Sheets.Count).Delete
    Application.DisplayAlerts = True
    Sheets(BlaNa).Select
    Application.ScreenUpdating = True
    Range("CV1").Select
    Beep
End Sub

Was die Angelegenheit mit dem Diagramm betrifft, so bitte ich Dich, doch diesbezüglich einen neuen Thread aufzumachen.

Zum Einen handelt es sich dabei um ein völlig neues Problem, zum Andern arbeite ich zwar gelegentlich auch mit Diagrammen, allerdings nur manuell; mit Makros, die Diagramme erzeugen oder bestehende verändern, habe ich mich noch nie befasst.

Von daher ist es sicherlich effizienter, wenn diesen Part ein Diagramm-Makroerfahrener Forumsteilnehmer übernimmt.

Ich bitte dafür um Verständnis.

MfG
WernerB.

Re: Nachtrag
von: Ingo J.
Geschrieben am: 10.05.2002 - 20:30:50

Danke,

Du hast mir sehr weitergeholfen. Ich hätte wahrscheinlich wochenlang gegrübelt wie ich das hinbekomme.

Werde die neue Formel gleich ausprobieren.
Was den Rest angeht ist kein Problem, das bekomme ich auch noch irgendwie zusammen.

MfG
Ingo