Office: Diagramme aus Datenreihen erstellen - Excel VBA

Hallo!



Ich würde mich sehr freuen, wenn mir jemand dabei behilflich sein könnte.

Gruß
Denjiro

 

Hallo Denjiro,

das sollte generell kein Problem sein (habe schon ein klein wenig damit gespielt).

Folgende Fragen hätte ich aber vorher noch:
- sind Deine "Daten.txt" alle vom Aufbau identisch? Wichtig z.Bsp.: fangen die Daten immer erst in der 2. Zeile an? Sind die Zahlenwerte immer gleich lang?
- sollen die Diagramme unter- oder nebeneinander positioniert werden? (je nach Breite/Höhe würde sich das eine oder andere evtl. anbieten)
- wie ist Deine Ordnerstruktur aufgebaut? Sind alle Deine "Daten-Ordner" in einem Überordner?
- nach welchem System sind die "Daten-Ordner" benannt? Alle einfach durchnummeriert?
- wie komplex soll die Auswahl für die einzulesenden Dateien sein? Reicht ein einfaches "von x bis y" oder muss es ähnlich wie bei der Seitenauswahl im Druckdialog gestaltet werden, wo man einzelne (auch mehrere) - komplette Bereiche - und auch beides gemischt angeben kann.

 

Hallo Achim,

vielen Dank schon mal.

 

Hi Denjiro,

weshalb benötigst du für jede Spalte ein eigenes Diagramm? Wäre es nicht sinnvoller, die Daten aus allen belegten Spalten als Datenreihen in einem gemeinsamen Diagramm darzustellen, sodass man die Werte gut miteinander vergleichen kann?
Welchen Diagrammtyp möchtest du verwenden?

Bis später,
Karin

 

Hallo Karin,

 

Hallo Denjiro,

ich denke die beigefügte Datei dürfte in etwa Deine Anforderungen erfüllen.
Den Anhang Diagramme.xlsm betrachten

<strike>Eins ist aber noch verbesserungswürdig:
Wenn ich mit</strike>

Code:

.Shapes.AddChart.Select

<strike>ein Diagramm einfüge, zieht Excel direkt die Daten aus allen Spalten. Erst durch die nachfolgenden Befehle wird nur die jeweilige Spalte zugewiesen.
Ich vermute, das dieses Verhalten bei vielen und langen Datenspalten ein echter Geschwindigkeitskiller ist.
Möglich auch, das es an meinen lokalen Einstellungen liegt.

Jedenfalls habe ich dies leider nicht besser hinbekommen, denke aber das Karin (oder jemand anderes) da sicher weiterhelfen könnte.</strike>

UPDATE: das Leben kann so einfach sein, einfach vorher die entsprechende Spalte selektieren ...



Ich bin von den folgenden Voraussetzungen ausgegangen:
- die Datei mit dem Makro liegt im gleichen Ordner wie der Ordner "Datendateien".
- der Ordner "Datendateien" enthält die von Dir angesprochenen, durchnummerierten Unterordner mit den Textdateien
- die Unterordner sind durchnummeriert und haben ansonsten keinerlei Bezeichnung, also (1 oder 01 oder 001 usw.)
- die Textdateien sind alle mit "Daten.txt" benannt
- sowohl die Auswahl der einzulesenden Dateien, als auch die Auswahl der darzustellenden Datenspalten erfolgt entweder als Bereich von Zahlen, oder es werden alle genommen (also z.Bsp: "3 - 5", "3, 5, 8" geht hier nicht, das war mir zu aufwendig). Das bedeutet, wenn eine einzelne Datei oder Spalte ausgewählt werden soll, erfolgt dies so: "2 - 2" (war halt erstmal der einfachste Weg)
- die Text-Dateien sind alle vom gleichen Aufbau wie Deine Beispieldatei


Arbeitsweise des Makros:
Nach Klick auf den CommandButton in meiner Datei wird die Prozedur "Public Sub MainSubDiagramme()" aufgerufen.
Als Auslöser kann anstelle des Buttons natürlich auch etwas ganz anderes gewählt werden.
Von dieser Prozedur aus werden die einzelnen Arbeitsschritte (Unterprozeduren) aufgerufen, als da wären:
- Auswahl des Nummerierungsbereiches der Unterordner ( z.Bsp. "1 - 5")
- Auswahl des Nummerierungsbereiches der Datenspalten ( z.Bsp. "2 - 5"), wird hier die Spalte "1" angegeben, wird sie automatisch als "2" gewertet, denn in der ersten Spalte steht ja immer die Zeit
- alle Unterordner deren Nummerierung der Auswahl entspricht, werden nach "Daten.txt" durchsucht
- die gefundenen Dateien werden in einem Array gespeichert
- eine neue Excel-Mappe wird erstellt
- eine Schleife öffnet alle Dateien aus dem Array und kopiert die Daten in jeweils ein neues Blatt in die neue Excel-Mappe
- in jedem Blatt werden alle Datenspalten, die nicht dem Auswahlbereich entsprechen, gelöscht
- für die restlichen Spalten werden Diagramme erzeugt
- die neue Mappe wird gespeichert
- auf das Ausschalten der Bildschirmaktualisierung habe ich verzichtet, da bei mir sonst zeitweise ein weißer Bildschirm angezeigt wird. So sieht man jetzt wenigstens das etwas passiert. Die beiden entsprechenden Code-Zeilen sind aber bereits vorhanden, bei Bedarf muss nur jeweils das Hochkomma am Anfang der Zeile entfernt werden.


Da ich Dein Verständnis für VBA-Code nicht einschätzen kann und das Projekt eh schon etwas länger gedauert hat als gedacht, habe ich auf Kommentierungen im Code verzichtet.
Wenn Du etwas nicht verstehst, frage bitte nach.

Falls ein Fehler auftritt, oder etwas nicht Deinen Anforderungen entspricht, frage bitte auch nach.


Und wer immer Verbesserungsvorschläge zum Code hat, ist herzlich eingeladen sie hier kund zu tun.



Ich hoffe geholfen zu haben.

 

Hi Denjiro,

ich habe gerade festgestellt, dass mein Beitrag von gestern Nachmittag hier gar nicht angezeigt wird. Aus diesem Grund noch einmal der von mir dort gepostete Code (in einem allgemeinen Modul):

Code:

Option Explicit

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
         .Columns(1).TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, 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 = xlXYScatterLines
            ' 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 wird jeweils ein neues Tabellenblatt eingefügt (Name entspricht dem Unterordner), die Daten aus der Textdatei in Spalte A eingefügt und dann mittelst Daten -> Text in Spalten "zerlegt". In Abhängigkeit von der Anzahl an Spalten wird dann die entsprechende Anzahl an Diagrammen untereinander erstellt.

Bis später,
Karin

 

Vielen Dank! Ich werde die beiden Makros im Laufe des Tages ausprobieren.

 

Hallo!

 

Hallo Denjiro,

das Dezimaltrennzeichen kann man so ändern:

Code:

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

Frag mich bitte nicht warum ein Punkt mit einem Punkt ersetzt wird, ich weiß es nicht.
Punkt durch Komma ersetzen führt zu Zahlensalat.
So funktioniert es aber, übrigens egal ob nun Punkt oder Komma in den ".txt" verwendet wird.


Um die Überschriften mit einzubeziehen und diese auch in den Dias zu verwenden, muss die Importmethode geändert werden, da bei der bisherigen die Spalten der Überschriften und der Daten nicht übereinstimmen würden.


Und so nebenbei bin ich noch über einen Fehler im "MainSub" gestolpert, der beim Speichern auftreten konnte.

Die Datei mit dem abgeänderten Code hänge ich hier: Den Anhang Diagramme.xlsm betrachten
noch mal drann, zur besseren Übersicht aber hier auch alle Änderungen die ich im Code vorgenommen habe:

Code:

Option Explicit

Dim varInputBox As Variant
[COLOR=#ff0000]Dim varMsgBox As Variant[/COLOR]
Dim varDatei As Variant

[COLOR=#ff0000]Dim loRow As Long
Dim loColumn As Long[/COLOR]
Dim loCounter As Long
Dim loShapeTop As Long

Code:

Public Sub MainSubDiagramme()

(...)

        Application.DisplayAlerts = False
        wbZiel.Worksheets(1).Delete
        Application.DisplayAlerts = True
[COLOR=#ff0000]        If Not Dir(ThisWorkbook.Path & "\Diagramme Auswertung.xlsx") = "" Then
            varMsgBox = MsgBox("Eine Datei mit dem Namen: ""Diagramme Auswertung.xlsx""  existiert bereits." _
                        & vbNewLine & vbNewLine & "Zum Überschreiben drücken Sie bitte ""Ja""," _
                        & vbNewLine & "Mit ""Nein"" können Sie manuell unter einem anderen Namen oder an einem anderen Ort speichern.", vbYesNo, "Namenskonflikt")
            Select Case varMsgBox
                Case vbYes
                    bolAbbruch = False
                    For Each objFile In Workbooks
                        If objFile.Name = "Diagramme Auswertung.xlsx" Then
                            MsgBox "Eine Datei mit dem Namen ""Diagramme Auswertung.xlsx"" ist bereits geöffnet." & vbNewLine _
                                    & "Bitte speichern Sie die neue Mappe manuell.", vbOKOnly, "Namenskonflikt"
                            bolAbbruch = True
                            Exit For
                        End If
                    Next objFile
                    If Not bolAbbruch = True Then
                        Application.DisplayAlerts = False
                        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Diagramme Auswertung.xlsx" _
                            , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                        Application.DisplayAlerts = True
                    End If
                Case vbNo
                    ' mach nix
            End Select
        Else
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Diagramme Auswertung.xlsx" _
                , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        End If[/COLOR]

Code:

Public Sub Diagramme()
    
    Workbooks.OpenText Filename:=DatPath(varDatei) & "\" & DatName(varDatei) _
        , Origin:=xlMSDOS, StartRow:=[COLOR=#ff0000]1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Space:=True, TrailingMinusNumbers:=True[/COLOR]
    
    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)
        
        [COLOR=#ff0000]If .Cells(1, 1) = "" Then .Columns(1).EntireColumn.Delete shift:=xlToLeft[/COLOR]
        
        [COLOR=#ff0000]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[/COLOR]
        
        .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"
            [COLOR=#ff0000].Range(.Cells(2, loCounter), .Cells(loRow, loCounter)).Select[/COLOR]
            .Shapes.AddChart.Select
            With ActiveChart
                .ChartType = xlColumnClustered
                .SetSourceData Source:=[COLOR=#ff0000]Range(Cells(2, loCounter), Cells(loRow, loCounter))[/COLOR]
                .Axes(xlCategory).Select
                .SeriesCollection(1).XValues = [COLOR=#ff0000]Range(Cells(2, 1), Cells(loRow, 1))[/COLOR]
                .SeriesCollection(1).Name = [COLOR=#ff0000]Cells(1, loCounter)[/COLOR]
            End With

Wenn Du etwas nicht verstehst bzw. zu etwas eine Erklärung haben möchtest, melde Dich.



Ich hoffe geholfen zu haben.

 

Hi,

um ein Diagramm zu erstellen, muss man weder den Zellbereich markieren, noch muss man das Diagramm selektieren (siehe mein Code):

Code:

         ' neues Diagramm erzeugen          
         With .ChartObjects.Add(0, dblTop, 400, 250).Chart

Bekanntlich beeinträchtigt das Markieren/Selektieren von Zellen/Objekten die Performance eines Codes sehr stark und ist außerdem in den meisten Fällen überhaupt nicht erforderlich. Solche "Select" ergeben sich aus einem mit dem Makrorekorder aufgezeichneten Code, der jeden einzelnen Schritt aufzeichnet, weshalb man ihn im Nachhinein noch bearbeiten sollte.

Bis später,
Karin

 

Hallo!

 

Hi Denjiro,

meinst du, dass keine Diagramme erstellt oder keine Graphen in den Diagrammen geplottet werden? Was verstehst du unter "erste Version"?



Übrigens habe ich gerade festgestellt, dass im Code aus meinem Beitrag vom 02.07.12 08:11 noch ein Fehler ist in der Zeile, welche die importierten Texte in die Spalten zerlegt. Diese Zeile müsste korrekt so heißen:

Code:

         .Columns(1).TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, [COLOR=#ff0000]ConsecutiveDelimiter:=True,[/COLOR] Space:=True

Dieser Zusatz bewirkt, dass aufeinanderfolgende mehrfach vorkommende Trennzeichen als 1 Zeichen interpretiert werden.

Bis später,
Karin

 

Hallo Karin,

Du hast natürlich völlig recht, "Select" sollte man generell vermeiden.
Aber, in diesem Fall kann ich keinen besseren Code anbieten, denn wenn ich das neue Chart nicht selektiere, gibt es Fehlermeldungen innerhalb des "With activechart".

Den Zellbereich zu selektieren ist eigentlich vollkommener Schwachfug, aber ...
Wenn man den Code im Einzelschrittmodus durchlaufen lässt und vorher nicht den Bereich selektiert sieht man, dass sich das Diagramm die Daten aus der kompletten Tabelle zieht.
Da der TO von langen Listen und vielen Spalten gesprochen hat bin ich davon ausgegangen, dass das "Select" immernoch schneller ist als unnötig viele Daten zu verarbeiten.
Und auf meinem altersschwachen Rechner merke ich da schon einen Unterschied.

Generell ist mein Code vermutlich nicht die beste Methode, aber die beste die ich anbieten kann, da ich nicht weiß wie es besser geht.
Und Deinen Code hatte ich nicht ans Laufen bekommen, da ich nicht wusste wo der Fehler lag.

Und genau deshalb finde ich es immer sehr interessant (und fruchtbar) wenn sich mehrere Leute in ein Thema einbringen.
;)

 

Hallo!