Makro zur Erstellung dynamischer Datenreihen HILFE

Hallo zusammen,
ich brauche dringend Hilfe...
Ich habe ein Makro geschreiben zur Auswertung von Daten, die in einem Diagramm dargestellt werden sollen.
Die Anzahl der Daten der einzelnen Kennlinien ist allerdings dynamisch, nach jeder Messung habe ich unterschiedlich viele Daten.
Insgesamt sind es 6 Datenreihen die ich richtig ornen uss und dann in Tabelle übertragen.
Dazu habe ich folgendes Makro zusammen geschustert, allerdings läuft es mehr schlecht als Recht.
Hat nicht noch jemand Tips?
Vielleicht kommt ja auch wer aus Braunschweig und Umgebung, der mir hier weiterhelfen könnte!
Es ist wirklich dringend!
Vielen Dank.
Sub Tabelle_einzeln()
Dim Bezeichnung1 As Variant
Dim Anfang1 As Variant
Dim AnfangWiderstand As Variant
Dim Zahlenanfang As Variant
Dim Zahlenanfang1 As Variant
Dim Temperatur As Object
Dim Widerstandswerte As Variant
Dim Widerstandswerte1 As Variant
Dim Bezeichnung_Kennlinie As Variant
Dim Zahlenreihe1x As String
Dim Zahlenreihe1y As String
Dim Zahlenreihe2x As String
Dim Zahlenreihe2y As String
Dim Zahlenreihe3x As String
Dim Zahlenreihe3y As String
Dim Zahlenreihe4x As String
Dim Zahlenreihe4y As String
Dim Zahlenreihe5x As String
Dim Zahlenreihe5y As String
Dim Zahlenreihe6x As String
Dim Zahlenreihe6y As String
ChDir "\Dokumente und Einstellungen\Privat.COMPUTERNAME\Desktop\MEF"
ChDrive "c:\"
'Das Dialogfenster
Bezeichnung1 = Application.GetOpenFilename("Alle Dateien (*.*), *.*")
If Bezeichnung1 = False Then Exit Sub
Sheets("Tabelle1").Select
Workbooks.OpenText Filename:=Bezeichnung1 _
, Origin:=932, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=False
Bezeichnung_Kennlinie = ActiveCell.Worksheet.Name
Set Fundstelle = Range("A4:A25").Find("Kraft[N]")
If Not Fundstelle Is Nothing Then
Fundstelle.Activate
Anfang1 = Fundstelle.Address 'Zelle für Kraft[N]
Else
MsgBox "Der Anfangswert konnte nicht ermittelt werden. Makro wird geschlossen!", vbCritical
Exit Sub
End If
Set Zahlenanfang = ActiveSheet.Range(Anfang1).Rows(2) 'erster Wert ausgewählt
Zahlenanfang.Activate
Zahlenanfang1 = Zahlenanfang.Address 'Messwertreihen ordnen
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe1x = Selection.Address
Set Widerstandswerte = ActiveSheet.Range(Zahlenanfang1).Columns(2) 'Widerstandswerte normalisieren
Widerstandswerte.Select
Range(Widerstandswerte, [B2000]).Select
Selection.NumberFormat = "General"
Widerstandswerte.Activate
Widerstandswerte1 = Widerstandswerte.Address
Widerstandswerte.Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe1y = Selection.Address
Zahlenanfang.Activate 'Rahmen setzen
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveSheet.Range(Anfang1).Columns(4).Select
Zahlenanfang.Activate 'Messwertreihen ordnen
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Zahlenanfang.Select
ActiveSheet.Range(Zahlenanfang1).Columns(4).Select
ActiveSheet.Paste
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(4).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe2x = Selection.Address
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(5).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe2y = Selection.Address
Zahlenanfang.Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
ActiveSheet.Range(Zahlenanfang1).Columns(7).Select
ActiveSheet.Paste
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(7).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe3x = Selection.Address
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(8).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe3y = Selection.Address
Zahlenanfang.Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
ActiveSheet.Range(Zahlenanfang1).Columns(10).Select
ActiveSheet.Paste
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(10).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe4x = Selection.Address
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(11).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe4y = Selection.Address
Zahlenanfang.Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Cut
ActiveSheet.Range(Zahlenanfang1).Columns(13).Select
ActiveSheet.Paste
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(13).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe5x = Selection.Address
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(14).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe5y = Selection.Address
Zahlenanfang.Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
ActiveSheet.Range(Zahlenanfang1).Columns(16).Select
ActiveSheet.Paste
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(16).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe6x = Selection.Address
Zahlenanfang.Activate
ActiveSheet.Range(Zahlenanfang1).Columns(17).Select
Range(Selection, Selection.End(xlDown)).Select
Zahlenreihe6y = Selection.Address
Zahlenanfang.Activate
Charts.Add
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
ActiveChart.SetSourceData Source:=Worksheets(Bezeichnung_Kennlinie).Range("A10:M202"), _
PlotBy:=xlColumns
ActiveChart.SeriesCollection(1).Delete 'vorhandene Kennlinie löschen
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection.NewSeries 'neue Kennlinie einfügen
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection.NewSeries
'Werte in Diagramm einfügen
ActiveChart.SeriesCollection(1).XValues = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe1x)
ActiveChart.SeriesCollection(1).Values = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe1y)
ActiveChart.SeriesCollection(1).Name = "=""1. Kraft steigend"""
ActiveChart.SeriesCollection(2).XValues = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe2x)
ActiveChart.SeriesCollection(2).Values = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe2y)
ActiveChart.SeriesCollection(2).Name = "=""1. Kraft fallend"""
ActiveChart.SeriesCollection(3).XValues = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe3x)
ActiveChart.SeriesCollection(3).Values = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe3y)
ActiveChart.SeriesCollection(3).Name = "=""2. Kraft steigend"""
ActiveChart.SeriesCollection(4).XValues = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe4x)
ActiveChart.SeriesCollection(4).Values = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe4y)
ActiveChart.SeriesCollection(4).Name = "=""2. Kraft fallend"""
ActiveChart.SeriesCollection(5).XValues = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe5x)
ActiveChart.SeriesCollection(5).Values = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe5y)
ActiveChart.SeriesCollection(5).Name = "=""3. Kraft steigend"""
ActiveChart.SeriesCollection(6).XValues = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe6x)
ActiveChart.SeriesCollection(6).Values = Worksheets(Bezeichnung_Kennlinie).Range(Zahlenreihe6y)
ActiveChart.SeriesCollection(6).Name = "=""3. Kraft fallend"""
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Kennlinie"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Widerstand-Kraft-Kennlinie " & Bezeichnung_Kennlinie
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Kraft [N]"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Widerstand [MOhm]"
End With

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Zahlenanfang.Activate Zahlenanfang1 = Zahlenanfang.Address 'Messwertreihen ordnen Range(Selection, Selection.End(xlDown)).Select Zahlenreihe1x = Selection.Address Set Widerstandswerte = ActiveSheet.Range(Zahlenanfang1).Columns(2) 'Widerstandswerte _ normalisieren Widerstandswerte.Select Range(Widerstandswerte, [B2000]).Select Selection.NumberFormat = "General" Widerstandswerte.Activate Widerstandswerte1 = Widerstandswerte.Address Widerstandswerte.Select Range(Selection, Selection.End(xlDown)).Select Zahlenreihe1y = Selection.Address

Option Explicit Sub Diagramm_formatieren() Dim s As Series, _ c As Chart, _ test As String 'Ggf. Diagramm aktivieren test = ActiveSheet.Name For Each c In ActiveWorkbook.Charts If c.Name = test Then test = "##Diagramm##" Exit For End If Next c If test "##Diagramm##" Then ActiveSheet.ChartObjects(1).Activate End If 'Diagramm als eigenes Blatt, benutzerdef. Größe ActiveChart.Location Where:=xlLocationAsNewSheet With ActiveChart.PageSetup .Orientation = xlLandscape .Zoom = 100 .ChartSize = xlScreenSize End With 'Größe und Position festlegen With ActiveChart.ChartArea .Height = 199 '7 cm x 28,41 .Width = 426 '15 cm x 28,41 .Left = 100 .Top = 100 End With 'Y-Achse formatieren With ActiveChart.Axes(xlValue) .TickLabels.AutoScaleFont = False .TickLabels.Font.Name = "Verdana" .TickLabels.Font.FontStyle = "Fett" .TickLabels.Font.Size = 8 End With 'X-Achse formatieren With ActiveChart.Axes(xlCategory) .TickLabels.AutoScaleFont = False .TickLabels.Font.Name = "Verdana" .TickLabels.Font.FontStyle = "Fett" .TickLabels.Font.Size = 8 End With 'Titel formatieren With ActiveChart.ChartTitle .Font.Name = "Verdana" .Font.FontStyle = "Fett" .Font.Size = 10.5 End With 'Legende formatieren With ActiveChart.Legend .AutoScaleFont = False .Font.Name = "Verdana" .Font.FontStyle = "Fett" .Font.Size = 8 End With 'Zeichnungsbereich formatieren With ActiveChart.PlotArea .Interior.ColorIndex = xlNone End With 'Datenbeschriftungen einschalten ActiveChart.ApplyDataLabels AutoText:=True, LegendKey:=False, _ HasLeaderLines:=False, ShowSeriesName:=False, ShowCategoryName:=False, _ ShowValue:=True, ShowPercentage:=False, ShowBubbleSize:=False 'Datenbeschriftungen formatieren For Each s In ActiveChart.SeriesCollection With s.DataLabels .AutoScaleFont = False .Font.Name = "Verdana" .Font.FontStyle = "Fett" .Font.Size = 7 End With Next s End Sub

Moin Sebastian, jetzt haben wir uns natürlich überschnitten. Ich schaue mir Deine Version jetzt nicht an, sondern lade Dir die von mir aktualisierte Version hoch:
https://www.herber.de/bbs/user/44270.xls
Beachte:
- Ich habe ein (erstmal auskommentiertes) Auto-Start-Makro in den Code von "Diese Arbeitsmappe" getan.
- Ich verstecke nach dem Klick das Userform (nicht unload, so dass alle Felder weiterhin verfügbar sind).
- Ich habe diverse "Select"s rausgenommen - die braucht kein Mensch und es verrät, wie viel Du mit dem Makrorekorder gearbeitet hast :-)
- Beachte auch die Umstellungen / Änderungen der With..End With-Konstrukte, jetzt ist es stringenter.
- Die Formatierung der Datenreihen ist jetzt geschleift
- Den Fehlerabfang für das Dateiöffnen muss man dann auch wieder abstellen - gemacht.
Trendlinien-Formel: Direkt formatieren geht wohl nicht. Du könntest die Formel als String abgreifen:


ActiveChart.SeriesCollection(5).Trendlines(1).DataLabel.caption
oder
ActiveChart.SeriesCollection(5).Trendlines(1).DataLabel.text

dann umformen und formatieren und auf dem gleichen Wege wieder zurückschreiben. Aber das wäre eine Wissenschaft für sich. Bei normalen Datenpunkt-Beschriftungen kann man ein Zahlenformat (NumberFormat) vorgeben, aber anscheinend nicht für den Trendlinientext.
Wenn ich Dir nochmal für diese "Werte unter 20 und max-Werte" unter die Arme greifen soll, beschreibe bitte das Problem konkret: Welche Spalte, welche Werte, was soll passieren.
Bis später. Meine Deadline für die nächsten 3 Wochen: heute 15 Uhr!! Gruß, Wolli

Beliebteste Forumthreads (12 Monate)

Makro zur Erstellung dynamischer Datenreihen HILFE

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro zur Erstellung dynamischer Datenreihen HILFE

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread