Office: Diagramme aus Datenreihen erstellen - Excel VBA

Hi Achim,

wir "kennen" uns schon länger und du weißt, ich gebe solche Hinweise nicht, um deinen Code oder den eines anderen Helfers als schlecht hinzustellen, es geht einfach darum, Erfahrungen auszutauschen und auch anderen Usern dieses Forums nahe zu bringen. Davon lebt ja ein Forum.

Dein Code würde ohne Select so aussehen:

Code:

With ActiveSheet.Shapes.AddChart.Chart

Doch nun kommt das große "ABER" ;-):

Bei Erstellung eines Diagramms (von Hand und logischerweise mit aufgezeichnetem Code) wird zuerst ein Shape erstellt und auf diesem dann das eigentliche Diagramm, was ja dieser Code wiederspiegelt:

Code:

.Shapes.AddChart.Select

oder eben

Code:

.Shapes.AddChart.Chart

Automatisch wird dabei derjenige Zellbereich als Datenbereich zugewiesen, in dem sich der Cursor befindet. Befindet er sich innerhalb oder in der Nähe eines zusammenhängenden gefüllten Zellbereiches, wird automatisch dieser zusammenhängende Zellbereich als Datenquelle für das Diagramm verwendet. Befindet sich der Cursor dagegen weiter entfernt von einem gefüllten Zellbereich, wird das Diagramm sozusagen ohne Datenbereich erstellt. Das ist das Problem, wenn .Shapes.AddChart verwendet wird. Wenn ein neues Tabellenblatt erstellt wird, steht der Cursor ja automatisch in A1 und damit in der Nähe bzw. innerhalb des zusammenhängenden Zellbereichs mit Werten, die aus der Textdatei imporitert wurden. Deshalb wir dem Diagramm (im konkreten Fall unerwünschter Weise) der gesamte gefüllte Tabellenbereich zugewiesen.

Die folgende Codezeile dagegen:

Code:

With .ChartObjects.Add(Links, Oben, Breite, Höhe).Chart

erstellt ein ChartObject mit einem Chart. Dieses wird Excel-intern anders als das Shape behandelt, und es wird kein Datenbereich zugwiesen, gleichgültig wo sich der Cursor befindet.

Du siehst also, die Verwendung des ChartObjects anstelle des Shapes bietet einen wesentlichen Vorteil.

Bis später,
Karin

 

Hallo Karin,

Sry wenn dieser Eindruck entstanden ist. War nicht so beabsichtigt.
War ne harte Woche, vielleicht deshalb ...
Ich denke Du weißt, dass ich immer dankbar für Tipps und Verbesserungen bin und den 2. Teil des Zitates genauso sehe. (davon habe ich selber ja schon reichlich profitiert)
Egal, von mir aus "Schwamm drüber", okay?



Ich habe Deine folgende Zeile mal in meinen Code eingebaut:

Code:

With .ChartObjects.Add(Links, Oben, Breite, Höhe).Chart

Funktioniert prächtig, läuft spürbar/gefühlt schneller und es werden so einige Codezeilen auf einen Schlag unnötig.


Hier nochmal die komplette Prozedur:

Code:

Public Sub Diagramme()
    
    Workbooks.OpenText Filename:=DatPath(varDatei) & "\" & DatName(varDatei) _
        , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Space:=True, TrailingMinusNumbers:=True
    
    Workbooks(DatName(varDatei)).Worksheets(1).Copy After:=wbZiel.Worksheets(wbZiel.Worksheets.Count)
    wbZiel.Worksheets(wbZiel.Worksheets.Count).Name = Mid(DatPath(varDatei), InStrRev(DatPath(varDatei), "\") + 1)
    
    Workbooks(DatName(varDatei)).Close False
    
    With wbZiel.Worksheets(wbZiel.Worksheets.Count)
        
        If .Cells(1, 1) = "" Then .Columns(1).EntireColumn.Delete shift:=xlToLeft
        
        loRow = .Range("A:A").SpecialCells(xlCellTypeLastCell).Row
        loColumn = .Range("A:A").SpecialCells(xlCellTypeLastCell).Column
        .Range(.Cells(1, 1), .Cells(loRow, loColumn)).Replace What:=".", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows
        
        .Columns("A:A").NumberFormat = "hh:mm:ss"
        
        For loCounter = .UsedRange.Columns.Count To 2 Step -1
            If strColMsgBox = vbNo Then
                If Not loCounter >= CDbl(strColStart) Or Not loCounter <= strColEnd Then
                    .Columns(loCounter).EntireColumn.Delete shift:=xlToLeft
                End If
            End If
        Next loCounter
        loShapeTop = 0
        For loCounter = 2 To .UsedRange.Columns.Count
            .Columns(loCounter).EntireColumn.NumberFormat = "0.00000"
            With .ChartObjects.Add(0, loShapeTop, 400, 250).Chart       ' .ChartObjects.Add(Links, Oben, Breite, Höhe).Chart
                .ChartType = xlColumnClustered
                .SetSourceData Source:=Range(Cells(2, loCounter), Cells(loRow, loCounter))
                .SeriesCollection(1).XValues = Range(Cells(2, 1), Cells(loRow, 1))
                .SeriesCollection(1).Name = Cells(1, loCounter)
                .Legend.Delete
            End With
            loShapeTop = loShapeTop + .Shapes("Diagramm " & (loCounter - 1)).Height
        Next loCounter
        With .Cells.Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
    End With
    
End Sub

Übrigens habe ich noch ".Legend.Delete" hinzugefügt, da die Dias ja nur eine Datenreihe haben. (Ich fands optisch störend)




@ Denjiro
Guck doch mal ob dies etwas für Dich wäre:

Code:

.ChartType = xlLine

 

Hi Achim,

ich stimme dir zu, dass eine Legende eigentlich nicht notwendig ist, da es ja nur 1 Datenreihe je Diagramm gibt. Ein Diagramm wird standardmäßig mit Legende erstellt - man kann es aber auch gleich zu Beginn mit folgender Zeile ohne Legende erstellen und muss diese nicht nachträglich wieder löschen:

Code:

.HasLegend = False

Noch ein Tipp: man muss dem Diagramm nicht erst einen Datenbereich zuweisen mit .SetSourceData = ... - es reicht aus, wenn man dem "leeren" Diagramm eine neue Datenreihe zuweist und dieser dann die X-/Y-Werte und auch den Namen zuweist. Schau dir dazu in meinem Code mal diesen Teil an:

Code:

' Datenreihe hinzufügen
With .SeriesCollection.NewSeries
   .Name = Worksheets(strTabelle).Cells(1, intSpalte)
   ' X-Werte
   .XValues = Worksheets(strTabelle).Range(Worksheets(strTabelle).Cells(1, 2), Worksheets(strTabelle).Cells(lngLetzte, 2))
   ' Y-Werte
   .Values = Worksheets(strTabelle).Range(Worksheets(strTabelle).Cells(1, intSpalte), Worksheets(strTabelle).Cells(lngLetzte, intSpalte))
End With

Bis später,
Karin

 

Hallo Karin,

ich habe Deine beiden Tipps noch mit eingebaut:

Code:

With .ChartObjects.Add(0, loShapeTop, 400, 250).Chart
    .ChartType = xlLine
    .HasLegend = False
    With .SeriesCollection.NewSeries
        .Values = Range(Cells(2, loCounter), Cells(loRow, loCounter))
        .XValues = Range(Cells(2, 1), Cells(loRow, 1))
        .Name = Cells(1, loCounter)
    End With
End With

Inzwischen läuft das Makro um einiges schneller als ganz zu Anfang und ich habe auch wieder einiges gelernt.
Danke dafür.

 

Hallo!

 

Hi Denjiro,

ich habe den von mir bereits geposteten Code dahingehend angepasst bzw. geändert, dass die Zahlen in den Textdateien mit Punkt (.) anstelle von Komma (,) vorliegen und dass das Aufteilen in die einzelnen Spalten korrekt erledigt wird. Mit diesem überarbeiten Code funktioniert es bei mir:

Code:

Sub Start()
   Application.ScreenUpdating = False
   ' Ordnerliste mit Unterordner-Name von 1 bis 3 aufrufen
   ShowFolderList "D:\Test\", 1, 3     '<== Ordnername und Unterordner-Name anpassen
   Application.ScreenUpdating = False
End Sub

Sub ShowFolderList(folderspec, intStart, intEnde)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.SubFolders
    ' Schleife über alle Unterordner
    For Each f1 In fc
      ' Unterordner-Name ist numerisch
      If IsNumeric(f1.Name) Then
         ' Unterordner-Name liegt zwischen Startnummer und Endnummer
         If CInt(f1.Name) >= intStart And CInt(f1.Name) <= intEnde Then
            ' Daten einlesen
            Einlesen folderspec & f1.Name & "\Daten.txt", f1.Name
         End If
      End If
    Next
End Sub

Sub Einlesen(strDatei, strOrdner)
    Dim arrText()
    Dim lngZeile As Long
    Dim lngLetzte As Long
    Dim intSpalte As Integer
    ' Datei ist vorhanden
    If Dir(strDatei) <> "" Then
       ' Textdatei zum Einlesen öffnen
       Open strDatei For Input As #1
       ' Schleife bis Dateiende
       Do While Not EOF(1)
           ' Array dimensionieren in Abhängigkeit von der jeweiligen Zeilennummer der Textdatei
           ReDim Preserve arrText(lngZeile)
           ' Text zeilenweise ins Array schreiben
           Line Input #1, arrText(lngZeile)
           lngZeile = lngZeile + 1
       Loop
       ' Textdatei schließen
       Close #1
       ' neues Tabellenblatt erstellen
       With Worksheets.Add
         ' Name = Name des Unterordners
         .Name = strOrdner
         ' Daen aus dem Array eintragen
         For lngZeile = 0 To lngZeile - 1
           If arrText(lngZeile) <> "" Then
             .Cells(lngZeile + 1, 1) = arrText(lngZeile)
           End If
         Next lngZeile
         ' Daten -> Text in Spalten
         .UsedRange = Application.Substitute(.UsedRange, ".", ",")
         .Columns(1).TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Space:=True
         ' Diagramme erstellen mit Übergabe des Tabellennamen und letzter belegter Zelle in Spalte B
         DiasErstellen (.Name), IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
      End With
   End If
End Sub

Sub DiasErstellen(strTabelle, lngLetzte)
   Dim intSpalte As Integer
   Dim dblTop As Double
   With Worksheets(strTabelle)
      ' Schleife von Spalte 3 bis zur letzten belegten der Zeile 1
      For intSpalte = 3 To IIf(IsEmpty(Cells(1, .Columns.Count)), .Cells(1, .Columns.Count).End(xlToLeft).Column, .Columns.Count)
         ' Festlegung der Position Oberkante des Diagramms
         If .ChartObjects.Count = 0 Then
            dblTop = 10
         Else
            dblTop = .ChartObjects(.ChartObjects.Count).BottomRightCell.Top
         End If
         ' neues Diagramm erzeigen
         With .ChartObjects.Add(0, dblTop, 400, 250).Chart
            ' Diagrammtyp Punkt(XY)
            .ChartType = xlXYScatterSmoothNoMarkers
            ' Datenreihe hinzufügen
            With .SeriesCollection.NewSeries
               .Name = Worksheets(strTabelle).Cells(1, intSpalte)
               ' X-Werte
               .XValues = Worksheets(strTabelle).Range(Worksheets(strTabelle).Cells(1, 2), Worksheets(strTabelle).Cells(lngLetzte, 2))
               ' Y-Werte
               .Values = Worksheets(strTabelle).Range(Worksheets(strTabelle).Cells(1, intSpalte), Worksheets(strTabelle).Cells(lngLetzte, intSpalte))
            End With
         End With
      Next intSpalte
   End With
End Sub

Es werden Diagramme vom Typ xlXYScatterSmoothNoMarkers erstellt. Der Typ xlLine ist meines Erachtens für die gegebenen Werte nicht geeignet.

Bis später,
Karin

PS: falls Fragen zum Code sind, kann ich sie erst nächste Woche beantworten (bis dahin - Urlaub)

 

Schönen Urlaub Karin.


@Denjiro

Ich habs gerade nochmal mit der aller ersten Version meiner Mappe getestet:
Auch da werden die X-Werte bei dem gewählten Diagrammtyp nicht korrekt angezeigt.

Ich vermute es liegt an den Uhrzeit-Werten.
Irgendwie werden die bei diesem Diagrammtyp nicht korrekt erkannt, skaliert oder was auch immer.


Leider kann ich Dir da nicht weiterhelfen, da bin ich auch mit meiner Weisheit am Ende.

Allerdings, mit "xline" werden die Werte meiner Meinung nach korrekt dargestellt und gezeichnet, oder irre ich mich da?
Was an dem Format ist für diese Daten denn nicht geeignet?

 

Hallo!

 

Hallo Denjiro,

tut mir wirklich leid, aber mit Diagrammen kenne ich mich nicht gut genug aus um Dir ab hier noch helfen zu können.

Wenn ich allerdings lese: "... mehr als 30 Spalten ...", dann denke ich sofort an Arbeitsspeicher.
Keine Ahnung obs wirklich so ist, aber soviele Diagramme dürften den Rechner (oder Excel) wohl an die Leistungsgrenze bringen.
Könnte ich mir zumindest vorstellen.

Mit meiner alten Gurke habe ich folgendes getestet:
- 36 Ordner mit identischer Datendatei erstellt
- Deine Original-Datendatei genommen und die Überschriften sowie die ersten beiden Datenzeilen auf 36 Spalten erweitert

Während der 6. Datei habe ich das Makro abgebrochen weil der Rechner den Kriechgang eingelegt hatte (bei sowenig Daten - 2 Zeilen).

Vielleicht wäre es ein Ansatz zuerst alle Daten einzulesen und erst danach, Blatt für Blatt die Dias zu erstellen?
Bist Du fit genug in VBA um diese Änderung selber zu bewerkstelligen?
Im Moment habe ich nicht wirklich viel Zeit für sowas.

 

Hallo Achim!

 

Hi Denjiro,

solche Pauschalantworten wie: "Ich kriege dein Makro bisher leider nicht zu laufen" sind für einen Helfer nicht sehr hilfreich. Du müsstest schon mal genau sagen, was du bei meinem Makro nicht zum Laufen bekommst - also wo genau hängt es?

Bis später,
Karin



Bis später,
Karin