' ========================================= ' 1) Widerstandsdiagramme für die Standard Messung ' ========================================= Sub AktualisiereXYDiagrammWiderstand() Dim datenWs As Worksheet Dim diagrammWs As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim xRange As Range Dim yRange As Range Dim letzteSpalte As Long Dim letzteZeile As Long Dim i As Long ' Arbeitsblätter definieren Set datenWs = ThisWorkbook.Worksheets(1) ' Blatt mit den Daten Set diagrammWs = ThisWorkbook.Worksheets(3) ' Blatt mit dem Diagramm ' Diagramm definieren Set chartObj = diagrammWs.ChartObjects(1) ' Diagrammname anpassen Set diagramm = chartObj.Chart ' Letzte Zeile und Spalte der Daten finden letzteZeile = datenWs.Cells(datenWs.Rows.Count, 1).End(xlUp).Row ' X-Werte in Spalte A letzteSpalte = datenWs.Cells(3, datenWs.Columns.Count).End(xlToLeft).Column ' Y-Werte ab Spalte B ' MsgBox letzteZeile, vbInformation ' MsgBox letzteSpalte, vbInformation ' X-Werte-Bereich definieren (fix in Spalte A, ab Zeile 3) Set xRange = datenWs.Range(datenWs.Cells(3, 1), datenWs.Cells(letzteZeile, 1)) ' Daten beginnen ab Zeile 3 ' Bestehende Datenreihen im Diagramm entfernen Do While diagramm.SeriesCollection.Count > 0 diagramm.SeriesCollection(1).Delete Loop ' Neue Datenreihen hinzufügen For i = 2 To letzteSpalte ' Y-Werte beginnen in Spalte B Set yRange = datenWs.Range(datenWs.Cells(3, i), datenWs.Cells(letzteZeile, i)) ' Neue Datenreihe hinzufügen With diagramm.SeriesCollection.NewSeries .Name = datenWs.Cells(2, i).Value ' Name der Reihe aus der Kopfzeile (Zeile 1) .XValues = xRange .Values = yRange .Smooth = False ' Glätten ausschalten End With Next i End Sub ' ========================================= ' 2) Kraftdiagramme für die Standard Messung ' ========================================= Sub AktualisiereXYDiagrammKraft() Dim datenWs As Worksheet Dim diagrammWs As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim xRange As Range Dim yRange As Range Dim letzteSpalte As Long Dim letzteZeile As Long Dim i As Long ' Arbeitsblätter definieren Set datenWs = ThisWorkbook.Worksheets(2) ' Blatt mit den Daten Set diagrammWs = ThisWorkbook.Worksheets(4) ' Blatt mit dem Diagramm ' Diagramm definieren Set chartObj = diagrammWs.ChartObjects(1) ' Diagrammname anpassen Set diagramm = chartObj.Chart ' Letzte Zeile und Spalte der Daten finden letzteZeile = datenWs.Cells(datenWs.Rows.Count, 1).End(xlUp).Row ' X-Werte in Spalte A letzteSpalte = datenWs.Cells(3, datenWs.Columns.Count).End(xlToLeft).Column ' Y-Werte ab Spalte B 'MsgBox letzteZeile, vbInformation 'MsgBox letzteSpalte, vbInformation ' X-Werte-Bereich definieren (fix in Spalte A, ab Zeile 3) Set xRange = datenWs.Range(datenWs.Cells(3, 1), datenWs.Cells(letzteZeile, 1)) ' Daten beginnen ab Zeile 3 ' Bestehende Datenreihen im Diagramm entfernen Do While diagramm.SeriesCollection.Count > 0 diagramm.SeriesCollection(1).Delete Loop ' Neue Datenreihen hinzufügen For i = 2 To letzteSpalte ' Y-Werte beginnen in Spalte B Set yRange = datenWs.Range(datenWs.Cells(3, i), datenWs.Cells(letzteZeile, i)) ' Neue Datenreihe hinzufügen With diagramm.SeriesCollection.NewSeries .Name = datenWs.Cells(2, i).Value ' Name der Reihe aus der Kopfzeile (Zeile 1) .XValues = xRange .Values = yRange .Smooth = False ' Glätten ausschalten End With Next i End Sub ' ========================================= ' 5) Widerstandsdiagramme für die Inkrement-Messung (Position-Gruppierung) ' ========================================= Sub AktualisiereXYDiagrammInkrementWiderstandPosition() Dim wsBasis As Worksheet Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteZeile As Long Dim letzteSpalte As Long Dim blockAnzahl As Long Dim startZeile As Long Dim posIndex As Integer ' Arbeitsblatt "Widerstandsdiagramm" festlegen Set wsBasis = ThisWorkbook.Worksheets("Widerstandsdiagramm") ' --- Schritt 1: Anzahl der Positions-Blöcke ermitteln --- ' Wir nehmen das erste Messblatt vor "Widerstandsdiagramm" als Referenz For Each ws In ThisWorkbook.Worksheets If ws.Index < wsBasis.Index Then letzteSpalte = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column blockAnzahl = Int(letzteSpalte / 3) Exit For End If Next ws If blockAnzahl = 0 Then MsgBox "Keine Datenblöcke gefunden.", vbExclamation Exit Sub End If ' --- Schritt 2: Diagramm im Basisblatt für Position 1 aktualisieren --- Call AktualisiereDiagrammFuerPosition(wsBasis, 1) ' --- Schritt 3: Für jede weitere Position Blatt kopieren und Diagramm anpassen --- For posIndex = 2 To blockAnzahl wsBasis.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count-1) With ActiveSheet .Name = "Widerstandsdiagramm" & posIndex Call AktualisiereDiagrammFuerPosition(ActiveSheet, posIndex) End With Next posIndex End Sub Private Sub AktualisiereDiagrammFuerPosition(wsDiagramm As Worksheet, posIndex As Integer) Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteZeile As Long Dim datenBereichX As Range Dim datenBereichY1 As Range Dim datenReihe As Series Dim startSpalte As Long Dim startZeile As Long Dim reihenName As String ' Diagramm im Blatt suchen If wsDiagramm.ChartObjects.Count = 0 Then Exit Sub Set chartObj = wsDiagramm.ChartObjects(1) Set diagramm = chartObj.Chart ' Vorhandene Datenreihen löschen Do While diagramm.SeriesCollection.Count > 0 diagramm.SeriesCollection(1).Delete Loop ' Spalten für gewünschte Position bestimmen startSpalte = (posIndex - 1) * 3 + 1 startZeile = 3 ' Alle Messblätter vor "Widerstandsdiagramm" durchlaufen For Each ws In ThisWorkbook.Worksheets If ws.Index < ThisWorkbook.Worksheets("Widerstandsdiagramm").Index Then letzteZeile = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row If letzteZeile >= startZeile Then With ws ' X und Y1 für diese Position Set datenBereichX = .Range(.Cells(startZeile, startSpalte), .Cells(letzteZeile, startSpalte)) Set datenBereichY1 = .Range(.Cells(startZeile, startSpalte + 1), .Cells(letzteZeile, startSpalte + 1)) ' Reihenname: Blattname + A1 + Position reihenName = ws.Name ' Datenreihe hinzufügen Set datenReihe = diagramm.SeriesCollection.NewSeries datenReihe.Values = datenBereichY1 datenReihe.XValues = datenBereichX datenReihe.Name = reihenName On Error Resume Next datenReihe.Smooth = False On Error GoTo 0 End With End If End If Next ws End Sub ' ========================================= ' 6) Kraftdiagramme für die Inkrement-Messung (Position-Gruppierung) ' ========================================= Sub AktualisiereXYDiagrammInkrementKraftPosition() Dim wsBasis As Worksheet Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteZeile As Long Dim letzteSpalte As Long Dim blockAnzahl As Long Dim posIndex As Integer ' Arbeitsblatt "Kraftdiagramm" festlegen Set wsBasis = ThisWorkbook.Worksheets("Kraftdiagramm") ' --- Schritt 1: Anzahl der Positions-Blöcke ermitteln --- ' Wir nehmen das erste Messblatt vor "Widerstandsdiagramm" als Referenz For Each ws In ThisWorkbook.Worksheets If ws.Index < ThisWorkbook.Worksheets("Widerstandsdiagramm").Index Then letzteSpalte = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column blockAnzahl = Int(letzteSpalte / 3) Exit For End If Next ws If blockAnzahl = 0 Then MsgBox "Keine Datenblöcke gefunden.", vbExclamation Exit Sub End If ' --- Schritt 2: Diagramm im Basisblatt für Position 1 aktualisieren --- Call AktualisiereDiagrammFuerPosition_Kraft(wsBasis, 1) ' --- Schritt 3: Für jede weitere Position Blatt kopieren und Diagramm anpassen --- For posIndex = 2 To blockAnzahl wsBasis.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) With ActiveSheet .Name = "Kraftdiagramm" & posIndex Call AktualisiereDiagrammFuerPosition_Kraft(ActiveSheet, posIndex) End With Next posIndex End Sub Private Sub AktualisiereDiagrammFuerPosition_Kraft(wsDiagramm As Worksheet, posIndex As Integer) Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteZeile As Long Dim datenBereichX As Range Dim datenBereichY2 As Range Dim datenReihe As Series Dim startSpalte As Long Dim startZeile As Long Dim reihenName As String ' Diagramm im Blatt suchen If wsDiagramm.ChartObjects.Count = 0 Then Exit Sub Set chartObj = wsDiagramm.ChartObjects(1) Set diagramm = chartObj.Chart ' Vorhandene Datenreihen löschen Do While diagramm.SeriesCollection.Count > 0 diagramm.SeriesCollection(1).Delete Loop ' Spalten für gewünschte Position bestimmen startSpalte = (posIndex - 1) * 3 + 1 startZeile = 3 ' Alle Messblätter vor "Widerstandsdiagramm" durchlaufen For Each ws In ThisWorkbook.Worksheets If ws.Index < ThisWorkbook.Worksheets("Widerstandsdiagramm").Index Then letzteZeile = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row If letzteZeile >= startZeile Then With ws ' X und Y2 für diese Position Set datenBereichX = .Range(.Cells(startZeile, startSpalte), .Cells(letzteZeile, startSpalte)) Set datenBereichY2 = .Range(.Cells(startZeile, startSpalte + 2), .Cells(letzteZeile, startSpalte + 2)) ' Reihenname: Blattname reihenName = ws.Name ' Datenreihe hinzufügen Set datenReihe = diagramm.SeriesCollection.NewSeries datenReihe.Values = datenBereichY2 datenReihe.XValues = datenBereichX datenReihe.Name = reihenName On Error Resume Next datenReihe.Smooth = False On Error GoTo 0 End With End If End If Next ws End Sub ' ========================================= ' 3) Widerstandsdiagramme für die Inkrement-Messung (Messung-Gruppierung) ' ========================================= Sub AktualisiereXYDiagrammInkrementWiderstand() Dim wsBasis As Worksheet Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteSpalte As Long Dim blockAnzahl As Long Dim messungIndex As Integer ' Arbeitsblatt "Widerstandsdiagramm" festlegen Set wsBasis = ThisWorkbook.Worksheets("Widerstandsdiagramm") ' --- Anzahl der Positions-Blöcke ermitteln (aus erstem Messblatt) --- For Each ws In ThisWorkbook.Worksheets If ws.Index < wsBasis.Index Then letzteSpalte = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column blockAnzahl = Int(letzteSpalte / 3) Exit For End If Next ws If blockAnzahl = 0 Then MsgBox "Keine Datenblöcke gefunden.", vbExclamation Exit Sub End If ' --- Diagramm im Basisblatt für Messung 1 aktualisieren --- Call AktualisiereDiagrammFuerMessung_Widerstand(wsBasis, 1, blockAnzahl) ' --- Für jede weitere Messung: Blatt kopieren --- For messungIndex = 2 To wsBasis.Index - 1 wsBasis.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count-1) With ActiveSheet .Name = "Widerstandsdiagramm" & messungIndex Call AktualisiereDiagrammFuerMessung_Widerstand(ActiveSheet, messungIndex, blockAnzahl) End With Next messungIndex End Sub Private Sub AktualisiereDiagrammFuerMessung_Widerstand(wsDiagramm As Worksheet, messungNr As Integer, blockAnzahl As Long) Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteZeile As Long Dim datenBereichX As Range Dim datenBereichY1 As Range Dim datenReihe As Series Dim posIndex As Integer Dim startSpalte As Long Dim startZeile As Long ' Diagramm im Blatt suchen If wsDiagramm.ChartObjects.Count = 0 Then Exit Sub Set chartObj = wsDiagramm.ChartObjects(1) Set diagramm = chartObj.Chart ' Vorhandene Datenreihen löschen Do While diagramm.SeriesCollection.Count > 0 diagramm.SeriesCollection(1).Delete Loop startZeile = 3 Set ws = ThisWorkbook.Worksheets(messungNr) letzteZeile = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row If letzteZeile >= startZeile Then For posIndex = 1 To blockAnzahl startSpalte = (posIndex - 1) * 3 + 1 Set datenBereichX = ws.Range(ws.Cells(startZeile, startSpalte), ws.Cells(letzteZeile, startSpalte)) Set datenBereichY1 = ws.Range(ws.Cells(startZeile, startSpalte + 1), ws.Cells(letzteZeile, startSpalte + 1)) Set datenReihe = diagramm.SeriesCollection.NewSeries datenReihe.Values = datenBereichY1 datenReihe.XValues = datenBereichX datenReihe.Name = "Position " & posIndex datenReihe.Smooth = False Next posIndex End If End Sub ' ========================================= ' 4) Kraftdiagramme für die Inkrement-Messung (Messung-Gruppierung) ' ========================================= Sub AktualisiereXYDiagrammInkrementKraft() Dim wsBasis As Worksheet Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteSpalte As Long Dim blockAnzahl As Long Dim messungIndex As Integer ' Arbeitsblatt "Kraftdiagramm" festlegen Set wsBasis = ThisWorkbook.Worksheets("Kraftdiagramm") ' --- Anzahl der Positions-Blöcke ermitteln (aus erstem Messblatt) --- For Each ws In ThisWorkbook.Worksheets If ws.Index < ThisWorkbook.Worksheets("Widerstandsdiagramm").Index Then letzteSpalte = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column blockAnzahl = Int(letzteSpalte / 3) Exit For End If Next ws If blockAnzahl = 0 Then MsgBox "Keine Datenblöcke gefunden.", vbExclamation Exit Sub End If ' --- Diagramm im Basisblatt für Messung 1 aktualisieren --- Call AktualisiereDiagrammFuerMessung_Kraft(wsBasis, 1, blockAnzahl) ' --- Für jede weitere Messung: Blatt kopieren --- For messungIndex = 2 To ThisWorkbook.Worksheets("Widerstandsdiagramm").Index - 1 wsBasis.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) With ActiveSheet .Name = "Kraftdiagramm" & messungIndex Call AktualisiereDiagrammFuerMessung_Kraft(ActiveSheet, messungIndex, blockAnzahl) End With Next messungIndex End Sub Private Sub AktualisiereDiagrammFuerMessung_Kraft(wsDiagramm As Worksheet, messungNr As Integer, blockAnzahl As Long) Dim ws As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim letzteZeile As Long Dim datenBereichX As Range Dim datenBereichY2 As Range Dim datenReihe As Series Dim posIndex As Integer Dim startSpalte As Long Dim startZeile As Long ' Diagramm im Blatt suchen If wsDiagramm.ChartObjects.Count = 0 Then Exit Sub Set chartObj = wsDiagramm.ChartObjects(1) Set diagramm = chartObj.Chart ' Vorhandene Datenreihen löschen Do While diagramm.SeriesCollection.Count > 0 diagramm.SeriesCollection(1).Delete Loop startZeile = 3 Set ws = ThisWorkbook.Worksheets(messungNr) letzteZeile = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row If letzteZeile >= startZeile Then For posIndex = 1 To blockAnzahl startSpalte = (posIndex - 1) * 3 + 1 Set datenBereichX = ws.Range(ws.Cells(startZeile, startSpalte), ws.Cells(letzteZeile, startSpalte)) Set datenBereichY2 = ws.Range(ws.Cells(startZeile, startSpalte + 2), ws.Cells(letzteZeile, startSpalte + 2)) Set datenReihe = diagramm.SeriesCollection.NewSeries datenReihe.Values = datenBereichY2 datenReihe.XValues = datenBereichX datenReihe.Name = "Position " & posIndex datenReihe.Smooth = False Next posIndex End If End Sub ' ========================================= ' 7) Diagramme für die HF-Messung ' ========================================= Sub AktualisiereXYDiagrammHF() Dim datenWs As Worksheet Dim diagrammWs As Worksheet Dim chartObj As ChartObject Dim diagramm As Chart Dim xRange As Range Dim yRange As Range Dim letzteSpalte As Long Dim letzteZeile As Long Dim dataIndex As Long Dim chartIndex As Long Dim i As Long Dim s As Series Application.ScreenUpdating = False Application.EnableEvents = False ' Für Paare 2->6, 3->7, 4->8, 5->9 For dataIndex = 2 To 5 chartIndex = dataIndex + 4 Set datenWs = ThisWorkbook.Worksheets(dataIndex) Set diagrammWs = ThisWorkbook.Worksheets(chartIndex) Set chartObj = diagrammWs.ChartObjects(1) Set diagramm = chartObj.Chart letzteZeile = datenWs.Cells(datenWs.Rows.Count, 1).End(xlUp).Row letzteSpalte = datenWs.Cells(2, datenWs.Columns.Count).End(xlToLeft).Column Set xRange = datenWs.Range(datenWs.Cells(3, 1), datenWs.Cells(letzteZeile, 1)) Do While diagramm.SeriesCollection.Count > 0 diagramm.SeriesCollection(1).Delete Loop For i = 2 To letzteSpalte Set yRange = datenWs.Range(datenWs.Cells(3, i), datenWs.Cells(letzteZeile, i)) With diagramm.SeriesCollection.NewSeries .Name = datenWs.Cells(2, i).Value .XValues = xRange .Values = yRange .Smooth = False .ChartType = xlXYScatterLines ' --- Nur Linie, keine Punkte --- .MarkerStyle = xlMarkerStyleNone End With Next i ' ---- Farben der ersten 3 Serien fest zuweisen ---- If diagramm.SeriesCollection.Count >= 1 Then diagramm.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(255, 128, 64) If diagramm.SeriesCollection.Count >= 2 Then diagramm.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(255, 0, 0) If diagramm.SeriesCollection.Count >= 3 Then diagramm.SeriesCollection(3).Format.Line.ForeColor.RGB = RGB(0, 128, 189) Next dataIndex Application.EnableEvents = True Application.ScreenUpdating = True End Sub