sehr viele Diagramme automatisch erstellen

[Dedl]

Hallo liebe Mitglieder,

nachdem mir heute rasend schnell von 2 sehr freundlichen Mitgliedern geholfen wurde, bin ich so mutig und schildere auch noch mein 2. Problem:

Eine Tabelle enthält sehr viele Einträge (über 15.000 Zeilen). In Tabelle "Quelldatei" stehen die Daten.

Ein Datenblock beginnt immer in Spalte "A" mit einem Eintrag "Data No."., der nächste Block beginnt ebenfalls wieder mit "Data No." in Spalte "A". Nun würde ich von jedem der sehr, sehr vielen Blöcke (final rund 200) ein Diagramm benötigen, welche in X -Achse die Werte aus Spalte "B" und als Linie die Werte aus Spalte "C"  (AVE(Ev)) wiedergibt. 

Die Diagramme sollten als Titel jeweils den Straßennamen tragen (steht immer in der Zelle oberhalb der Zelle mit dem Inhalt "Data No.)
Das so oft, bis die Quelltabelle bis zum Ende durchgesucht wurde.

Diese Diagramme sollten im Tabellenblatt "Diagramme" erstellt werden um diese von dort aus dann später als PDF zu drucken.

Eine Beispieldatei (mit wenigen Demo Daten) füge ich bei.


  Demodatei Strassenauswertung mit Konsolidierung.xlsm (Größe: 42,21 KB / Downloads: 9)

Ich hoffe, 2. Fragen/Probleme an einem Abend ist nicht zuviel und ich bin wirklich sehr dankbar für eure Unterstützung und sage schon mal DANKE!

Viele Grüße
Detlef

[Elex]

Hi

Wie sollen die Diagramme aussehen bzw. auf dem Blatt angeordnet werden(3 Stück untereinander oder 2X3 oder ???). Größe? Legende? 
Etwas Vorleistung müsste noch kommen, sonst ist nachher wieder zu viel zu ändern.

Gruß Elex

[snb]

Ich fürchte du hast eene Aufgabe bekommen für die deine Kenntnisse nicht ausreichen.
Dann wäre es besser einen Dienstleister zu beauftragen.

[LCohen]

Schick wäre es doch dabei, "industriell" zu denken:

Statt die 200 Diagramme noch alle in Excel zu erzeugen und dann in einem Rutsch zu drucken (PDF), könnte man doch gleich nur ein einzelnes Diagramm (oder soviele, wie auf eine PDF-Seite kommen) als Seite drucken.

[UweD]

Hallo

- Ich hab mal ein XY Diagramm gewählt
- Deine X -Achsenwerte sind Text. Die solltest du in ein Datum TT.MM.JJJJ hh:mm:ss  umwandeln

Hier mal ein erster Entwurf

Code:

Sub Diagramme_erstellen()
    Dim TB As Worksheet, DB As Worksheet, DName As String, Anz As Long, Von As Long, Bis As Long
    Dim firstAddress As String, c As Variant, LR As Long
    Dim Off As Integer
    Dim Breite As Double, Hoehe As Double, Abst As Double
   
    Set TB = Sheets("Quelltabelle")
    DName = "Diagramme"
   
    Breite = 400    'Diagrammbreite
    Hoehe = 200     'Diagrammhöhe
    Abst = 1.1      'Abstandsfaktor zwischen den Diagrammen
   
    Off = 5         'ZeilenOffset von "Data No" bis vorheriges Ende
   
    'altes Blatt löschen und Neues anlegen
    If Not IsError(Evaluate(DName & "!A1")) Then
        Application.DisplayAlerts = False
            Sheets(DName).Delete
        Application.DisplayAlerts = False
    End If
    Set DB = Sheets.Add(After:=Sheets(Sheets.Count))
    DB.Name = DName
   
    Von = 2 'Startzeile
   
    LR = TB.Cells(TB.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
   
    With TB.Columns(1)
        Set c = .Find(What:="Data No.", After:=.Cells(Von, 1), LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
           
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                Bis = c.Row - Off
                If Bis < Von Then Bis = LR 'Wichtig beim Letzten Fund
               
                'neues Diagramm erzeugen
                DB.Shapes.AddChart2(240, xlXYScatterLinesNoMarkers, 10, Hoehe * Anz * Abst, Breite, Hoehe).Select
               
                With ActiveChart
                    'Datenbereich festlegen
                    .SetSourceData Source:=TB.Cells(Von + 1, 2).Resize(Bis - Von, 2)
               
                    'Diagrammtitel
                    .ChartTitle.Text = TB.Cells(Von - 1, 1)
                   
                End With
                   
                'nächstes
                Anz = Anz + 1
                Von = c.Row ' neue Startzeile
                Set c = .FindNext(c)
           
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
   
    MsgBox Anz & " Diagramme eingefügt."
   
End Sub

LG UweD