Datenimport und Diagrammerstellung

Hallo,
ich möchte mehrere .txt-Dateien in eine Excel Arbeitsmappe importieren.
Aus diesen Dateien soll ein Diagramm erstellt werden, mit y-Achse primär und sekundär.
In der angehängten Excel Tabelle wären die Daten für das Diagramm:
x-Achse A39 bis Ende
y primär C39 bis Ende
y sekundär F39 bis Ende
Dazu habe ich ein Makro gefunden, das gut zu meiner Aufgabe passt.
Mein Problem allerdings ist, dass ich im Makro nicht die Bereiche definieren kann, die den jeweiligen Achsen zugeordnet werden sollen
Kann mir das jemand weiterhelfen?
https://www.herber.de/bbs/user/136317.txt

Sub blattimportieren()
Dim ordner As Variant, wbAct As Workbook, wbNeu As Workbook, Abfrage
Dim objBlatt As Worksheet
Dim strBlattName As String
Dim i As Integer
Dim j As Integer
Dim k As Variant
Dim Bereich As Range
Dim AnzZeilen As Long
Abfrage = vbYes 'Initialisierung
Application.ScreenUpdating = False
'Löschen aller Arbeitsblätter bis auf das erste
Application.DisplayAlerts = False
strBlattName = "Tabelle1"
On Error Resume Next
Worksheets(strBlattName).Activate
If Err.Number  0 Then
Err.Clear
End If
For Each objBlatt In Sheets
If objBlatt.Name  "Tabelle1" Then objBlatt.Delete
Next
Application.DisplayAlerts = True
'Import der Dateien
Do Until Abfrage = vbNo
ordner = Application.GetOpenFilename("Alle Dateien,*.*")
If ordner = False Then Exit Sub
Set wbAct = ActiveWorkbook
Set wbNeu = Workbooks.Open(ordner)
wbNeu.Sheets.Copy After:=wbAct.Sheets(1)
wbAct.Activate
wbNeu.Close False
Abfrage = MsgBox("Weitere Datei importieren?", vbYesNo, "Abfrage")
Loop
'Löschen der übrigen Tabellenblätter
Application.DisplayAlerts = False
Sheets("Tabelle1").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
MsgBox ("Import beendet." & Chr(13) & Chr(13) & "Diagrammerstellung beginnt.")
'Kopieren relevanter Daten in Tabellenblatt Zusammenfassung
Sheets.Add
ActiveSheet.Name = "Zusammenfassung"
i = 1
j = 1
Sheets(i + 1).Select
Rows(3).Copy
Sheets(1).Cells(j, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Do Until i = Worksheets.Count
i = i + 1
j = j + 1
Sheets(i).Select
AnzZeilen = IIf(Len(Cells(Rows.Count, 1)), Rows.Count, Cells(Rows.Count, 1).End(xlUp). _
Row)
Rows(AnzZeilen).Copy
Sheets(1).Cells(j, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("B5").Copy
Sheets(1).Cells(j, 3).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Loop
Sheets(1).Activate
Columns("C:C").NumberFormat = "0"
'Daten aufbereiten und Diagramm erstellen
k = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Range("C1").ClearContents
Columns("A:B").Delete Shift:=xlToLeft
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Charts.Add
ActiveChart.ChartType = xl3DArea
ActiveChart.SetSourceData Source:=Sheets("Zusammenfassung").Rows("1:" & k), _
PlotBy:=xlRows
ActiveChart.Location Where:=xlLocationAsNewSheet
With ActiveChart
.HasTitle = False
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Characters.Text = "Frequenz"
.Axes(xlSeries).HasTitle = True
.Axes(xlSeries).AxisTitle.Characters.Text = "Drehzahl"
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Characters.Text = "Amplitude"
End With
With ActiveChart.Axes(xlCategory)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
With ActiveChart.Axes(xlSeries)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
With ActiveChart.Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
ActiveChart.WallsAndGridlines2D = False
ActiveChart.HasLegend = False
'Löschen der importierten Tabellenblätter
Application.DisplayAlerts = False
strBlattName = "Tabelle1"
On Error Resume Next
Worksheets(strBlattName).Activate
If Err.Number  0 Then
Err.Clear
End If
For Each objBlatt In Sheets
If objBlatt.Name  "Zusammenfassung" And objBlatt.Name  "Diagramm1" Then objBlatt.Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Manche Teile des Makros scheinen außerdem völlig belanglos zu sein.
Bspw. dieser hier hat überhaupt keinen Effekt:

      'Löschen aller Arbeitsblätter bis auf das erste
Application.DisplayAlerts = False
strBlattName = "Tabelle1"
On Error Resume Next
Worksheets(strBlattName).Activate
If Err.Number  0 Then
Err.Clear
End If
For Each objBlatt In Sheets
If objBlatt.Name  "Tabelle1" Then objBlatt.Delete
Next
Application.DisplayAlerts = True

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim lngReihe As Long Dim lngLetzte As Long With Worksheets("Zusammenfassung") lngLetzte = IIf(IsEmpty(.Cells(Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, _ Rows.Count) End With With ActiveChart For lngReihe = .SeriesCollection.Count To 1 Step -1 .SeriesCollection(lngReihe).Delete Next lngReihe With .SeriesCollection.NewSeries .XValues = Worksheets("Zusammenfassung").Range("A39:A" & lngLetzte) .Values = Worksheets("Zusammenfassung").Range("C39:C" & lngLetzte) End With With .SeriesCollection.NewSeries .XValues = Worksheets("Zusammenfassung").Range("A39:A" & lngLetzte) .Values = Worksheets("Zusammenfassung").Range("F39:F" & lngLetzte) End With End With

Sub blattimportieren() Dim ordner As Variant, wbAct As Workbook, wbNeu As Workbook, Abfrage 'Import der Dateien Application.ScreenUpdating = False Do Until Abfrage = vbNo ordner = Application.GetOpenFilename("Alle Dateien,*.*") If ordner = False Then Exit Sub Set wbAct = ActiveWorkbook Set wbNeu = Workbooks.Open(ordner) wbNeu.Sheets.Copy After:=wbAct.Sheets(1) wbAct.Activate wbNeu.Close False Abfrage = MsgBox("Weitere Datei importieren?", vbYesNo, "Abfrage") Loop End Sub

Sub Diagramm() Dim wks As Worksheet, intI As Integer Dim intRange As Integer Dim strRange_X As String, strRange_Y As String, strRange_Name As String 'wie kriegt man hier noch eine sekundäre Y-Achse unter? Dim objChart As Chart, wksDiagramm As Worksheet Dim objReihe As Series ActiveWorkbook.Worksheets.Add before:=ActiveWorkbook.Sheets(1) Set wksDiagramm = ActiveSheet wksDiagramm.Shapes.AddChart Set objChart = wksDiagramm.ChartObjects(1).Chart objChart.ChartType = xlXYScatterLinesNoMarkers For intI = 1 To 10 'wie macht man das ohne bestimmte Anzahl? Set wks = ActiveWorkbook.Worksheets("Werte" & Format(intI, "0")) 'wie kann man "Werte" ersetzen, so dass er die Namen der Arbeitsblätter ignoriert? 'bei "" akzeptiert er nur Arbeitsblätter die eine Ziffer als Namen haben For intRange = 1 To 3 'Aus einem Arbeitsblatt wird nur ein Datensatz benötigt strRange_X = "='" & wks.Name & "'!" _ & wks.Range("A39:A1000").Offset(0, (intRange - 1) * 3).AddressLocal 'wäre am besten, wenn er bis zum Ende zählt, aber sowas wie "Rows.Count, Cells(Rows.Count, 1). _ _ _ _ End(xlUp).Row)" konnte ich hier nicht erfoglreich einbringen 'auch diesen Teil bin ich nicht losgeworden: Offset(0, (intRange - 1) * 3).AddressLocal strRange_Y = "='" & wks.Name & "'!" _ & wks.Range("C39:D1000").Offset(0, (intRange - 1) * 3).AddressLocal strRange_Name = "='" & wks.Name & "'!" _ & wks.Range("B1").Offset(0, (intRange - 1) * 3).AddressLocal Set objReihe = objChart.SeriesCollection.NewSeries With objReihe .Name = strRange_Name .XValues = strRange_X .Values = strRange_Y 'sekundäre Y-Achse? End With Next intRange Next intI End Sub

Sehe ich das richtig, es soll nur ein einziges Diagramm in der Arbeitsmappe vorhanden sein, nur dass sich die Daten jedesmal ändern mit jedem neuen Import? In dem Fall muss es doch nicht jedesmal neu erstellt werden, es reicht, wenn sich der Datenbereich an die Anzahl an importierten Daten dynamisch anpasst - und das geht ohne VBA. Schau dir das im Anhang an: es sind Namen definiert - zum einen 1 Name für die X-Werte, die ja für alle 4 Datenreihen identisch sind (und dieselbe Anzahl an Werten umfassen), wenn ich das richtig gesehen habe. Und zum anderen je 1 Name für jede der 4 Datenreihen. Diese Namen sind als Datenquelle im Diagramm eingetragen.
https://www.herber.de/bbs/user/136406.xlsx

Beliebteste Forumthreads (12 Monate)

Datenimport und Diagrammerstellung

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread