Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1384to1388
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

mehrfache Schleifen

mehrfache Schleifen
20.10.2014 11:16:42
Stankowski
Hallo,
arbeite seit Wochen an einem Programm zur Erstellung von mehreren (ca. 60) Diagrammen aus einem Datenblatt.
Ich will aber nicht 60 mal jedes Diagramm programmieren.
nun meine Frage:
wie bekomme ich für die Variablen zellbezüge (sind bei jedem Diagramm anders) eine schleife hin, die in den deffinierten Zellabständen (immer 8 zeilen) die Daten abfragt und in die vorbereiteten Diagramme (1 - 60) einträgt.
VBA anbei für 2 Diagramme (sollen aber mal 60 werden)
Sub Scale_Chart()
Dim myrange As Range
Dim answerMax As Single
Dim answerMin As Single
'Diagramm 1
Set myrange = Worksheets("Prüfkarte spc").Range("e7:h13")
answerMax = Application.WorksheetFunction.Max(myrange)
answerMin = Application.WorksheetFunction.Min(myrange)
Worksheets("Urwertkarte").ChartObjects("diagramm 1").Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
With ActiveChart.Axes(xlValue)
.MinimumScale = answerMin
.MaximumScale = answerMax
.MajorUnit = Worksheets("Prüfkarte spc").Range("j7")
.MinorUnit = Worksheets("Prüfkarte spc").Range("j8")
.Crosses = xlAutomatic
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
'Beschrifung setzten
ActiveChart.Shapes(1).Delete
ActiveChart.Shapes.AddLabel(1, 0, 0, 200, 20).TextFrame.Characters.Text =  _
Worksheets("Prüfkarte spc").Range("j13")
End With
'Diagramm 2
Set myrange = Worksheets("Prüfkarte spc").Range("e15:h21")
answerMax = Application.WorksheetFunction.Max(myrange)
answerMin = Application.WorksheetFunction.Min(myrange)
Worksheets("Urwertkarte").ChartObjects("diagramm 2").Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
With ActiveChart.Axes(xlValue)
.MinimumScale = answerMin
.MaximumScale = answerMax
.MajorUnit = Worksheets("Prüfkarte spc").Range("j15")
.MinorUnit = Worksheets("Prüfkarte spc").Range("j16")
.Crosses = xlAutomatic
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
'Beschrifung setzten
ActiveChart.Shapes(1).Delete
ActiveChart.Shapes.AddLabel(1, 0, 0, 200, 20).TextFrame.Characters.Text =  _
Worksheets("Prüfkarte spc").Range("j21")
End With
End Sub

24
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: mehrfache Schleifen
20.10.2014 11:25:47
yummi
Hallo Stankowski,
mach daraus eine Funktion mit übergabeparameter :

function Scale_Chart(ByVal strRange as String, ByVal strMinor as String, ByVal strMajor as  _
String, ByVal iIndex as Integer, ByVal strLabel as String)
Dim myrange As Range
Dim answerMax As Single
Dim answerMin As Single
'Diagramm 1
Set myrange = Worksheets("Prüfkarte spc").Range(strRange)
answerMax = Application.WorksheetFunction.Max(myrange)
answerMin = Application.WorksheetFunction.Min(myrange)
Worksheets("Urwertkarte").ChartObjects("diagramm "& iIndex).Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
With ActiveChart.Axes(xlValue)
.MinimumScale = answerMin
.MaximumScale = answerMax
.MajorUnit = Worksheets("Prüfkarte spc").Range(strMajor)
.MinorUnit = Worksheets("Prüfkarte spc").Range(strMinor)
.Crosses = xlAutomatic
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
'Beschrifung setzten
ActiveChart.Shapes(1).Delete
ActiveChart.Shapes.AddLabel(1, 0, 0, 200, 20).TextFrame.Characters.Text =  _
Worksheets("Prüfkarte spc").Range(strLabel)
End With
end Function

Dann hast Du nur noch die Aufrufzeile für jedes Diagramm
Gruß
yummi
PS: ist ungetestet, hoffe sind keine Syntaxfehler drin ;-)

Anzeige
AW: mehrfache Schleifen
20.10.2014 11:36:50
Stankowski
Kannst du das noch genauer erklären was du da jetzt gemacht hast?
Startpunkt sind die Daten aus Diagramm 1. dann zu allen Bezügen immer 8 Zeilen weiter für Diagramm 2 usw.
bin nicht so der Fachmann:-)

AW: mehrfache Schleifen
20.10.2014 11:53:33
yummi
Hallo Stankowski,
ich habe die variablen Teile deines Diagramms als Aufrufparameter nach aussen gezogen. Dabei bin cih davon ausgegangen, dass der Code den Du gepostet hast dein Diagramm komplett zeichnet.
Aufruf für das 1. Diagramm wäre dann:
call Scale_Chart ("e7:h13", "j8", "j7", 1, "j21")
Die anderen Aufrufe analog.
Gruß
yummi

AW: mehrfache Schleifen
20.10.2014 12:19:33
Stankowski
Wahrscheinlich bin ich zu doof aber ich schnalls nicht.
es sind 60 Liniendiagramme (alle schon vorgezeichnet nur ohne Daten drin von Diagramm 1 bis 60), die mit den Daten aus Range gefüllt werden. Jedes mit einer anderen Range die zum vorhergehenden um 8 Zeilen nach unten verschoben ist.
Nun dachte ich es gibt eine "einfache" Möglichkeit den Zeilenbezug immer bei jedem Diagramm um 8 zu erhöhen (vergl. Diagramm 1 zu Diagramm 2) und das genau 60 mal zu machen.
Gleiches gilt natürlich auch für die anderen Werte die auch dem Datenblatt gezogen werden. immer 8 Zeilen weiter je Diagramm bis 60 Diagramme voll sind.

Anzeige
AW: mehrfache Schleifen
20.10.2014 12:40:06
yummi
Hallo Stankowski,
dann mal komplett (neu) ;-)

function Scale_Chart(ByVal iIndex as integer, ByVal iWert as Integer)
Dim myrange As Range
Dim answerMax As Single
Dim answerMin As Single
'Diagramm 1
Set myrange = Worksheets("Prüfkarte spc").Range("e" &iIndex & ":h"&iIndex + 6)
answerMax = Application.WorksheetFunction.Max(myrange)
answerMin = Application.WorksheetFunction.Min(myrange)
Worksheets("Urwertkarte").ChartObjects("diagramm "& iIndex).Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
With ActiveChart.Axes(xlValue)
.MinimumScale = answerMin
.MaximumScale = answerMax
.MajorUnit = Worksheets("Prüfkarte spc").Range("j"&iIndex)
.MinorUnit = Worksheets("Prüfkarte spc").Range("j" & iIndex + 1)
.Crosses = xlAutomatic
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
'Beschrifung setzten
ActiveChart.Shapes(1).Delete
ActiveChart.Shapes.AddLabel(1, 0, 0, 200, 20).TextFrame.Characters.Text =  _
Worksheets("Prüfkarte spc").Range("j" & iIndex+6)
End With
end Function
Sub ZeichneDiagramme
dim i as Integer
dim j as Integer
j= 1
for i  = 7 to 487 Step 8    '487 kann falsch sein muss deine Zeile des letzten Blocks rein
Call Scale_Chart (i,j)
j  = j + 1
next i
End Sub
Gruß
yummi

Anzeige
AW: mehrfache Schleifen
20.10.2014 14:26:49
Stankowski
wenn ich es so laufen lasse, bekomm ich die Fehlermeldung End

Sub fehlt

Sub diagramm()

Function Scale_Chart(ByVal iIndex As Integer, ByVal iWert As Integer)
Dim myrange As Range
Dim answerMax As Single
Dim answerMin As Single
'Diagramm 1
Set myrange = Worksheets("Prüfkarte spc").Range("e" & iIndex & ":h" & iIndex + 6)
answerMax = Application.WorksheetFunction.Max(myrange)
answerMin = Application.WorksheetFunction.Min(myrange)
Worksheets("Urwertkarte").ChartObjects("diagramm " & iIndex).Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
With ActiveChart.Axes(xlValue)
.MinimumScale = answerMin
.MaximumScale = answerMax
.MajorUnit = Worksheets("Prüfkarte spc").Range("j" & iIndex)
.MinorUnit = Worksheets("Prüfkarte spc").Range("j" & iIndex + 1)
.Crosses = xlAutomatic
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
'Beschrifung setzten
ActiveChart.Shapes(1).Delete
ActiveChart.Shapes.AddLabel(1, 0, 0, 200, 20).TextFrame.Characters.Text = _
Worksheets("Prüfkarte spc").Range("j" & iIndex + 6)
End With
End Function

End Sub


Sub ZeichneDiagramme()
Dim i As Integer
Dim j As Integer
j = 1
For i = 7 To 487 Step 8     '487 kann falsch sein muss deine Zeile des letzten Blocks rein
Call Scale_Chart(i, j)
j = j + 1
Next i
End Sub

Anzeige
AW: mehrfache Schleifen
20.10.2014 14:36:44
yummi
Hallo Stankowski,
wieso schachtelst du function in subs und die wiederum in subs?
Lad mal die Datei hoch, dann rück ich das mal gerade.
Gruß
yummi

AW: mehrfache Schleifen
20.10.2014 14:51:04
Stankowski
geht net zu groß
hast Mailadresse für mich?

AW: mehrfache Schleifen
20.10.2014 14:55:04
yummi
Hallo Stankowski,
nein kein Zugiff von hier. Pack mal und nimm bis auf 2 oder 3 diagramme den rest raus. Dann bau ich dir den Code, so dass du ihn in dieen orignial nur noch importieren brauchst.
Gruß
yummi

AW: mehrfache Schleifen
20.10.2014 15:17:33
yummi
Hallo Stankowski,
so läuft der Code bis zum Diagramm 6, dann bricht er mit Fehler ab, weil das Diagramm nicht da ist. Man könnte noch eien Sicherheitsabfrage einbauen.
Ich weiß nur nicht was er jetzt zeichnen soll, da kennst du dich besser aus :-)
Du musst nur ZeichneDiagramme an der entsprechenden Stelle aufrufen, der Rest läuft automatisch.
Gib mal feedback, ob es jetzt rund ist.
https://www.herber.de/bbs/user/93251.xlsm
Gruß
yummi

Anzeige
AW: mehrfache Schleifen
20.10.2014 18:07:36
Stankowski
habs eben bis Diagramm 40 erweitert aber ab Diagramm 6 stimmen die werte für die Linien nicht mehr.
ich meld mich morgen nochmal.
mach jetzt Feierabend.

AW: mehrfache Schleifen
20.10.2014 19:35:46
yummi
Hallo Stankowski,
prüf mal was ab Diagramm 6 mit den Werten anders ist. Zeile verschoben?
Wirf mal den Debugger an und zur Not selektiere mal die Range am Anfang der Funktion, damit Du siehst, wo er falsch zugreift.
Gruß
yummi

AW: mehrfache Schleifen
21.10.2014 12:52:45
Stankowski
folgende Fehlermeldung
Userbild

AW: mehrfache Schleifen
21.10.2014 23:43:41
yummi
Hallo Stankowski,
sry für die späte Antwort, aber ich hab erst wieder Freitag tagsüber Netzzugriff.
Bitte überprüfe mal den Wert von iIndex wenn der fehler auftritt.
Angenommen es steht 20 drin, dann schau mal bitte ob e20:h26 dem Bereich deines Diagramms entspricht. Mir scheint Du hast einen Zeilenversatz drin in deiner Tabelle, wo die Werte für deine Diagramme stehen. Wenn du dir gleichzeitig den Wert iWert anschaust, dann weißt Du auch welches Diagramm gerade gezeichnet werden soll.
Ich hoffe, dass hilft dir erstmal weiter. Ansonsten kann ich erst Freitag wieder schauen.
Gruß
yummi

Anzeige
AW: mehrfache Schleifen
22.10.2014 10:19:00
Stankowski
Hallo,
hab das Problem gelöst.
Aber trotzdem werden in dem Diagrammen die falschen werte angezeigt und teilweise keine Linien gezeichnet.
Auch die Beschriftung passt nicht zum Diagramm. Verschiebungen in den Zeilen erkenne ich keine.

AW: mehrfache Schleifen
22.10.2014 11:38:08
Stankowski
vielleicht könnten wir am Freitag telefonieren?

AW: mehrfache Schleifen
22.10.2014 19:28:21
yummi
Hallo Stankowski,
können wir versuchen ;-) sag einfach wann und Nummer
Gruß
yummi

AW: mehrfache Schleifen
24.10.2014 08:05:34
Stankowski
hast du gerade Zeit zum telefonieren?

AW: mehrfache Schleifen
24.10.2014 08:29:32
Stankowski
Hier nochmal das aktuelle File.
Problem: Die Daten werden nicht in die Diagramme geschrieben, oder nicht angezeigt (Keine Linien)
https://www.herber.de/bbs/user/93329.zip

Anzeige
AW: mehrfache Schleifen
24.10.2014 11:35:59
yummi
Hi,
ich hab dir mal ein Sheet check eingefügt, wo du die variablen Werte deienr einzelnen Diagramme siehst.
Wenn ich dann ein einzelnes Diagramm zeichen z.B. 13, welches nicht gezeichnet wird, dann wird das auch einzelnen mit den fixen Werten nicht gezeichnet.
Hast Du denn schon jemals das Diagramm 13 mit deinen Werten gesehen?
Prüf doch mal bitte, ob nicht beim zeichnen selber noch etwas nicht passt.
Zusätzlich habe ich noch auf deine Zelle mit der 280 vollständig referenziert (in der for Schleife)
Die Datei ist jetzt knapp zu groß, daher hier der Quelltext.
1. Deinem Button musst Du mit das Makro ZeichneDiagramm zuweisen
2. leg mal ein zusätzliches Blatt "check" an.

Function Scale_Chart(ByVal iIndex As Integer, ByVal iWert As Integer)
Dim myrange As Range
Dim answerMax As Single
Dim answerMin As Single
'Diagramm 1
Worksheets("check").Cells(iWert, 1).Value = "e" & iIndex & ":h" & iIndex + 6
Worksheets("check").Cells(iWert, 2).Value = "Diagramm " & iWert
Worksheets("check").Cells(iWert, 3).Value = "Major: " & "j" & iIndex
Worksheets("check").Cells(iWert, 4).Value = "Minor: " & "j" & iIndex + 1
Worksheets("check").Cells(iWert, 5).Value = "Beschriftung: " & "j" & iIndex + 6
Set myrange = Worksheets("Prüfkarte SPC").Range("e" & iIndex & ":h" & iIndex + 6)
answerMax = Application.WorksheetFunction.Max(myrange)
answerMin = Application.WorksheetFunction.Min(myrange)
Worksheets("Urwertkarte").ChartObjects("Diagramm " & iWert).Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
With ActiveChart.Axes(xlValue)
.MinimumScale = answerMin
.MaximumScale = answerMax
.MajorUnit = Worksheets("Prüfkarte SPC").Range("j" & iIndex)
.MinorUnit = Worksheets("Prüfkarte SPC").Range("j" & iIndex + 1)
.Crosses = xlAutomatic
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
'Beschrifung setzten
ActiveChart.Shapes(1).Delete
ActiveChart.Shapes.AddLabel(1, 0, 0, 200, 20).TextFrame.Characters.Text = _
Worksheets("Prüfkarte SPC").Range("j" & iIndex + 6)
End With
End Function
Sub ZeichneDiagramme()
Dim i As Integer
Dim j As Integer
j = 1
For i = 7 To Worksheets("Prüfkarte SPC").Cells(5, 12) Step 8
Call Scale_Chart(i, j)
j = j + 1
Next i
End Sub
Sub test13()
'Diagramm 13
Set myrange = Worksheets("Prüfkarte spc").Range("e103:h109")
answerMax = Application.WorksheetFunction.Max(myrange)
answerMin = Application.WorksheetFunction.Min(myrange)
Worksheets("Urwertkarte").ChartObjects("diagramm 13").Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
With ActiveChart.Axes(xlValue)
.MinimumScale = answerMin
.MaximumScale = answerMax
.MajorUnit = Worksheets("Prüfkarte spc").Range("j103")
.MinorUnit = CDbl(Worksheets("Prüfkarte spc").Range("j109"))
.Crosses = xlAutomatic
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
'Beschrifung setzten
ActiveChart.Shapes(1).Delete
ActiveChart.Shapes.AddLabel(1, 0, 0, 200, 20).TextFrame. _
Characters.Text = _
Worksheets("Prüfkarte spc").Range("j21")
End With
End Sub
Dann siehst du mit welchen Parametern die Diagramme gezeichnet werden.
Gruß
yummi

Anzeige
AW: mehrfache Schleifen
24.10.2014 11:45:27
Stankowski
hab ich gemacht, aber geht immer noch net.
Tel: T + 49 9651 53 330

AW: mehrfache Schleifen
24.10.2014 13:39:32
yummi
Hi,
zu deinem Problem der falschen Datenbereiche:
1. auf Prüfkarte SPC definierst du für Tabelle 1 den Beriech D8:H12 mit dem Namen "BereichTabelle1"
2. für alle anderen Tabellen anlog
Du kannst anschliessend im Namensmanager überprüfen, ob überall Werte hinterlegt sind.
Im Code folgende Änderung:

Worksheets("Urwertkarte").ChartObjects("Diagramm " & iWert).Activate
ActiveChart.SetSourceData Source:=Sheets("Prüfkarte SPC").Range("BereichTabelle" &  _
iWert)
die 2. Zeile dazu. Du kannst es auch ohne activate machen (flackert weniger)
wäre dann so:
Worksheets("Urwertkarte").ChartObjects("Diagramm " & iWert).SetSourceData Source:=Sheets("Prüfkarte SPC").Range("BereichTabelle" & iWert)
alles in einer Zeile
Diese Zeile schreibt dir automatisch die Datenquelle rein.
Wenn alle Namen BereichTabelle 1 bis BereichTabelle63 definiert sind und auf die richtigen Werte zugreifen, brauchst Du dich um die Datenquelle nicht mehr kümmern, da das das Makro für dich übernimmt.
Das Ausblenden deiern nicht benutzten Vorlagen so:

Function Ausblenden()
Dim i As Long
Dim lletzte As Long
lletzte = Worksheets("Prüfkarte SPC").Cells(Rows.Count, 4).End(xlUp).Row   'lertzte Zeile  _
Spalte 4
For i = 7 To lletzte Step 8
If IsError(Worksheets("Prüfkarte SPC").Cells(i, 5)) Then
Worksheets("Prüfkarte SPC").Rows(i - 1 & ":" & lletzte).Hidden = True
End If
Next i
End Function
Kannst Du aufrufen vor dem Zeichnen oder als Sub auf extra Button legen, wie du magst.
Sollte alle Probleme beheben ;-)
Gruß
yummi

Anzeige
AW: mehrfache Schleifen
20.10.2014 11:48:36
Klaus
Hi Stan,
ich hab in meinem Archiv noch einen Standardcode zur Diagrammerstellung gefunden. Vielleicht hilft der dir ja weiter.
Grüße,
Klaus M.vdT.
Option Explicit
'* Module for quick creation of charts in the active worksheet
'* created: June 2013 by Klaus M.vdT.
'* every feature after data-Range is optional!
Sub test()
Call MakeSingleChart(Range("B4:C12"), 1, Range("A1"), 300, 200, 10, 90, True)
Call MakeSingleChart(Range("B4:C12"), , , , , , , False)
Call MakeSingleChart(Range("B4:C12"))
End Sub
Sub MakeSingleChart( _
rngData As Range, _
Optional TypeChart As Integer, _
Optional rngTopLeftCell As Variant, _
Optional iHeight As Variant, _
Optional iWidth As Variant, _
Optional iScaleMin As Variant, _
Optional iScaleMax As Variant, _
Optional bNoLegend As Boolean)
'rngData = Range of Data
'TypeChart 1=Line, 2=Pie, 3=Column, 4=ColumnStacked, 5=ColumStacked100, none=Line
'rngTopLeftCell = Move Chart's top left corner to THIS cell, places in mid-screen if not  _
choosen
'iHeight and iWidth = Height/Width in Pixels, uses standard if not choosen
'iScaleMin and iScaleMax = FIX X-Axis to this value. If not choosen, chart will autoscale
'bNoLegend = if TRUE, Legend is removed. If FALSE or not choosen, Legend stays in the chart
On Error GoTo hell
'rngTopLeftCell hast to be a valid RANGE, iHeight a valid INTEGER and so on
'  Declaration has to be VARIANT to enable the ISMISSING feature. In case of wrong usage
'  (example: set height to "hello world") it will end with ONERROR
Dim myCht As Object
Set myCht = ActiveSheet.Shapes.AddChart       'create new Chart
With myCht
With .Chart
'Chart definitions ************************************
.ChartType = xlLine    'set Line as standard
Select Case TypeChart
Case 1
Case 2
.ChartType = xlPie
Case 3
.ChartType = xlColumnClustered
Case 4
.ChartType = xlColumnStacked
Case 5
.ChartType = xlColumnStacked100
Case Else
End Select
.SetSourceData Source:=rngData
' ************************************ Chart Definitions
If bNoLegend Then .Legend.Delete           'Legend or not?
End With
'move and scale ************************************
If Not IsMissing(iScaleMax) Then .Chart.Axes(xlValue).MaximumScale = iScaleMax
If Not IsMissing(iScaleMin) Then .Chart.Axes(xlValue).MinimumScale = iScaleMin
If Not IsMissing(rngTopLeftCell) Then
.Top = rngTopLeftCell.Top
.Left = rngTopLeftCell.Left
End If
If Not IsMissing(iHeight) Then .Height = iHeight
If Not IsMissing(iWidth) Then .Width = iWidth
'************************************ move and scale
End With
GoTo heaven:
hell:
'get rid of wrong chart
myCht.Delete
'display error messge
MsgBox "could not create chart!" & vbCrLf _
& "Error Number: " & Err.Number & _
vbCrLf & "Error: " & Err.Description
heaven:
End Sub

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige