Messprotokoll
14.04.2008 20:56:29
Ulli
folgende Aufgabe stellt sich mir:
Voran muss ich stellen, dass ich in VBA ein absoluter Neuling bin und mit dieser Aufgabe überfordert bin. Bisher habe ich die Tabelle per Hand formatiert und nur ein begrenztes Diagramm per VBA genutzt. Jetzt möchte ich jedoch, dass es möglichst automatisch funktioniert und mir somit eine gewisse Zeitersparnis bleibt.
Es handelt sich um ein Diagramm, welches aus einer Messreihe von 25 Stück. Immer vorhanden ist ein oberer und unterer Toleranzwert. Das Diagramm oder die Tabelle soll sich automatisch in folgender Reihenfolge einfärben:
1/6tel helles rot,
dann ein etwas dickerer roter Strich für die obere Toleranzgrenze,
1/6tel helles gelb,
dann ein etwas dickerer gelber Strich für die Eingriffsgrenze,
1/6tel helles grün,
dann ein etwas dickerer grüner Strich für den Toleranzmittelpunkt,
wieder 1/6tel helles grün,
dann ein etwas dickerer gelber Strich für die Eingriffsgrenze,
1/6tel helles gelb,
dann ein etwas dickerer roter Strich für die untere Toleranzgrenze,
1/6tel helles rot.
Die Werte X-Achse zieht sich das Diagramm aus der Tabelle selbst. Die Werte der Y-Achse zieht sich das Diagramm ebenfalls aus der Tabelle, können aber, bei einer automatischen Färbung des Diagramms auch in einem nicht Druckbereich stehen.
Die Begrenzung des Diagramms habe ich wie folgt erledigt:
Option Explicit
'* 23.02.06, *
'* angepasst 14.04.2008 *
'* angepasst von Ulli Wetzel, smudo1967@gmx.de *
Sub min_max_anpassen() ' neues Makro vom 14.04.2008
' durch Set ist eine Aktivierung des Diagramms nicht mehr nötig
Dim chDiagramm As Chart ' Variable für das Diagrammobjekt
' Prozedur verlassen wenn aktive Tabelle nicht Tabelle1 ist
If ActiveSheet.Name "Messprotokoll" Then Exit Sub
' Prozedur verlassen wenn keine numerischen Werte für Minimum und Maximum
If Not IsNumeric(Cells(64, 4)) Or Not IsNumeric(Cells(65, 4)) Then Exit Sub
' Prozedur verlassen wenn Maximum kleiner als Minimum
If Cells(65, 4) Makros ausgeführt werden kann
Private Sub min_max_anpassen_alteVersion() ' Makro vom 23.02.06
' Diagramm muss zur Übertragung der Werte aktiviert werden
Dim loAnfang As Long
Dim loEnde As Long
loAnfang = Cells(64, 4).Value
loEnde = Cells(65, 4).Value
Worksheets("Messprotokoll").ChartObjects("Diagramm 1").Activate
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
.MinimumScale = loAnfang
.MaximumScale = loEnde
End With
Worksheets("Messprotokoll").Range("D64").Activate
End Sub
Gerne schicke ich Euch auch die von Hand erstellte Tabelle.
Könnt Ihr mir dabei helfen?
Gruß Ulli