AW: VBA Problem
15.08.2006 15:10:01
Peter
Hallo,
1.
nachdem ich meine Tabellen bereinigt hatte (1. Zeile Überschrift ab 2. Zeile Daten),habe ich es nicht fehlerfrei geschaft die Bezüge in den Codes anzupassen.
Bitte zeige mir an welchen Stellen und wie ich was ändern muß.
(aktueller Code unten)
Bitte Hilfe!
2.
leider haben die Codes mit den Array-Variablen zu keine merklichen Erhöhung der Geschwindigkeit geführt. Ich habe sie trotzdem eingebaut.
Dadurch ist vielmehr ein neues Problem aufgetaucht:
Jetzt wird das 1. Merkmal das in der 4. Zeile in allen Tabellenblättern steht nicht mehr nach seiner Ausprägung (Farbe im Diagramm) untersucht. Vermutlich stimmt eine Zeilenzuordnung nicht, ich hab den Fehler nicht gefunden.
Bitte Hilfe!
3.
die Codes für die automatischen Neuberechnung und die Bildschirmanzeige habe ich im Sub Chart Activate und im Module1 mit Sub SpeedUp eingebaut.
Das bringt jetzt schon mal viel Geschwindigkeit.
Ist OK!
4.
Der Code mit dem Zellen ausblenden hat nichts gebracht!
'Nullstellen im Diagramm nicht anzeigen
Sheets("Hilfe").Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
Ich hab mich nochmal mit dem Beispiel befasst, allerdings akzeptiert Excel nicht meinen Dateinamen und die Definition der Namen und Werte ist mir auch unverständlich.
Wäre nett, wenn für meine Anwendung eine Anpassung erfolgen könnte!
Bitte Hilfe!
""VBA ist dafür nicht notwendig, nichtsdestotrotz muß man einwenig in die Trickkiste greifen.
1. die Werte- und Namenszuordung in der Grafik darf nicht direkt, sondern muß über einen Namen erfolgen
diese Zuordnung funktioniert aber in den Grafiken nur, wenn der Datei-Name vorangestellt wird (in Hochkommas und mit ! vom Namen getrennt)
Beispiel: ='Dynamische Grafik.xls'!Werte
2. die Namen müßen dynamisch sein, dh. die Definiton erfolgt nicht absolut, sondern über Formeln, die den Zellbereich automatisch anpassen:
Beispiel: Definition für "Werte" =BEREICH.VERSCHIEBEN(Tabelle1!$B$1;1;;ANZAHL2(Tabelle1!$B:$B)-1;)
Dann paßt sich auch die Grafik automatisch an. vorausetzung ist allerdings, daß die Tabelle keine Leerzeilen enthält.
Siehe Beispiel https://www.herber.de/bbs/user/35776.xls ""
nachfolgend meine aktuellen Codes:
1.Diagramm:
Dim altx As Integer
Dim alty As Integer
Dim AnzahlWerte As Integer
Private Sub Chart_Activate()
Dim index As Integer
With Application 'beschleunigt Berechnung
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
AnzahlWerte = Sheets("Hilfe").Range("$I$3").Value 'übernimmt Anzahl der Datensätze aus Zelle I3 vom Tabellenblatt "Hilfe"
'Löschen der vorherigen Anzeige beim wechsel von Tabellenblatt zum Diagrammblatt
'soll die vorherige Beschriftung beibehalten werden, dann das hier auskommentieren
'ggf dafür sorgen, dass gar kein Text mehr drin steht....
If altx <> 0 And alty <> 0 Then
Charts("Koordinaten Darstellung").SeriesCollection(altx).Points(alty).HasDataLabel = False
End If
'Alle Punkte sollen anhand der Daten unterschiedliche Farben bekommen
' alle Punkte bekommen ein Punkt als Form und die Größe 12
Charts("Koordinaten Darstellung").SeriesCollection(1).MarkerStyle = xlMarkerStyleCircle
Charts("Koordinaten Darstellung").SeriesCollection(1).MarkerSize = 8
' Auswahl im DropDown an aktueller Darstellung orientieren
' ggf eine andere Darstellung als Start wählen
Charts("Koordinaten Darstellung").Shapes("Drop Down 5").ControlFormat.Value = 1
Application.Run ("Kombinationsfeld")
' Focus auf das Diagramm legen, damit die lila Punkte verschwinden (bei Auswahl)
ActiveChart.PlotArea.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Private Sub Chart_MouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal y As Long)
Dim ElementID As Long, Arg1 As Long, Arg2 As Long
Dim myX As Variant, myY As Double
With ActiveChart
' Pass x & y, return ElementID and Args
.GetChartElement X, y, ElementID, Arg1, Arg2
'If ElementID = xlShape Then
'MsgBox ("Elemetid: " & ElementID & "...Arg1:" & Arg1 & "...Arg2:" & agr2)
'MsgBox (Charts("Koordinaten Darstellung").Shapes("Drop Down 5").ControlFormat.Value)
'MsgBox (Charts("Koordinaten Darstellung").Shapes("Drop Down 5").Type)
'MsgBox (Charts("Koordinaten Darstellung").Shapes("Drop Down 5").FormControlType)
'If Charts("Koordinaten Darstellung").Shapes("Drop Down 5").FormControlType = xlDropDown Then
'If Charts("Koordinaten Darstellung").Shapes("Drop Down 5").Type = msoFormControl Then
'MsgBox ("Drop down")
'End If
'End If
' Did we click over a point or data label?
If ElementID = xlSeries Or ElementID = xlDataLabel Then
If Arg2 > 0 Then
' Extract x value from array of x values
myX = WorksheetFunction.index _
(.SeriesCollection(Arg1).XValues, Arg2)
' Extract y value from array of y values
myY = WorksheetFunction.index _
(.SeriesCollection(Arg1).Values, Arg2)
' Display message box with point information
' MsgBox "Series " & Arg1 & vbCrLf _
' & """" & .SeriesCollection(Arg1).Name & """" & vbCrLf _
' & "Point " & Arg2 & vbCrLf _
' & "X = " & myX & vbCrLf _
' & "Y = " & myY
' Informationen des letzten angeklickten Punktes nicht mehr anzeigen
If altx <> 0 And alty <> 0 Then
With Charts("Koordinaten Darstellung").SeriesCollection(altx).Points(alty)
.HasDataLabel = False
End With
End If
' Informationen des aktuell angeklickten Punktes anzeigen
With Charts("Koordinaten Darstellung").SeriesCollection(Arg1).Points(Arg2)
.HasDataLabel = True
'die Beschriftung des Datensatzes als Text ausgeben
'.ApplyDataLabels Type:=xlDataLabelsShowLabel
' Text des Labels frei definieren:
' Text aus der Spalte J (in entsprechender Zeile) holen
.DataLabel.Text = Worksheets("Hilfe").Range("A" & Arg2 + 3)
' Schriftgrösse fest auf 8 einstellen
.DataLabel.Font.Size = 8
' Farbe des Textes setzen (1=schwarz)
.DataLabel.Font.ColorIndex = 1
End With
' aktuelle Werte für den nächsten klick merken
altx = Arg1
alty = Arg2
' Select auf das gesamte Diagramm setzen, damit die Punkte nicht Lila sind
ActiveChart.PlotArea.Select
End If
End If
End With
End Sub
2. Modul1:
Dim AnzahlWerte As Integer
Sub SpeedUp(bOn As Boolean)
If bOn Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Else
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Sub Kombinationsfeld()
SpeedUp (True)
' Anhand der Auswahl im DropDown-Feld werden unterschiedliche Legenden angezeigt
AnzahlWerte = Sheets("Hilfe").Range("$I$3").Value
'MsgBox (Charts("Koordinaten Darstellung").Shapes("Drop Down 5").ControlFormat.Value)
'MsgBox (Charts("Koordinaten Darstellung").SeriesCollection(1).Points.Count)
'zuerst alle Textboxen unsichtbar, um anschliessend die eine sichtbar zu machen
Charts("Koordinaten Darstellung").Shapes("Text Box 4").Visible = False
Charts("Koordinaten Darstellung").Shapes("Text Box 7").Visible = False
Charts("Koordinaten Darstellung").Shapes("Text Box 8").Visible = False
Charts("Koordinaten Darstellung").Shapes("Text Box 9").Visible = False
Charts("Koordinaten Darstellung").Shapes("Text Box 10").Visible = False
Charts("Koordinaten Darstellung").Shapes("Text Box 11").Visible = False
Select Case Charts("Koordinaten Darstellung").Shapes("Drop Down 5").ControlFormat.Value
Case 1
Charts("Koordinaten Darstellung").Shapes("Text Box 8").Visible = True
Application.Run ("Modul1.Auswahl1")
Case 2
Charts("Koordinaten Darstellung").Shapes("Text Box 9").Visible = True
Application.Run ("Modul1.Auswahl2")
Case 3
Charts("Koordinaten Darstellung").Shapes("Text Box 7").Visible = True
Application.Run ("Modul1.Auswahl3")
Case 4
Charts("Koordinaten Darstellung").Shapes("Text Box 4").Visible = True
Application.Run ("Modul1.Auswahl4")
Case 5
Charts("Koordinaten Darstellung").Shapes("Text Box 10").Visible = True
Application.Run ("Modul1.Auswahl5")
Case 6
Charts("Koordinaten Darstellung").Shapes("Text Box 11").Visible = True
Application.Run ("Modul1.Auswahl6")
Case 7
Application.Run ("Modul1.Auswahl7")
Case 8
Application.Run ("Modul1.Auswahl8")
Case 9
Application.Run ("Modul1.Auswahl9")
Case 10
Application.Run ("Modul1.Auswahl10")
Case 11
Application.Run ("Modul1.Auswahl11")
End Select
SpeedUp (False)
End Sub
Private Sub Auswahl1()
SpeedUp (True)
' Auswahl in der DropDown ist "Baum-Art"
Dim Werte
'Array-Variable zuweisen
arrWerte = Sheets("Datenübernahme").Range("B3:B" & AnzahlWerte + 2).Value
For index = 1 To AnzahlWerte
With Charts("Koordinaten Darstellung").SeriesCollection(1).Points(index)
'Farbe anhand des Eintrages in Spalte B
Select Case arrWerte(index, 1) 'hier wird die Array.Variable verwendet
Case "Eiche/Roteiche"
.MarkerForegroundColorIndex = 10
.MarkerBackgroundColorIndex = 10
End Select
End With
Next index
SpeedUp (False)
End Sub
Sub Auswahl2()
SpeedUp (True)
' Auswahl in der DropDown ist "Bearbeiter"
Dim Werte
'Array-Variable zuweisen
arrWerte = Sheets("Datenübernahme").Range("D3:D" & AnzahlWerte + 2).Value
For index = 1 To AnzahlWerte
With Charts("Koordinaten Darstellung").SeriesCollection(1).Points(index)
'Farbe anhand des Eintrages in Spalte D
Select Case arrWerte(index, 1) 'hier wird die Array.Variable verwendet
Case "1 = Nobis"
.MarkerForegroundColorIndex = 6
.MarkerBackgroundColorIndex = 6
Case "2 = Kalmukow"
.MarkerForegroundColorIndex = 4
.MarkerBackgroundColorIndex = 4
End Select
End With
Next index
SpeedUp (False)
End Sub
Public Sub Auswahl3()
SpeedUp (True)
' Auswahl in der DropDown ist "Stamm-Durchmesser in 1,3 m Höhe"
Dim Werte
'Array-Variable zuweisen
arrWerte = Sheets("Datenübernahme").Range("E3:E" & AnzahlWerte + 2).Value
For index = 1 To AnzahlWerte
With Charts("Koordinaten Darstellung").SeriesCollection(1).Points(index)
'Farbe anhand des Eintrages in Spalte E
Select Case arrWerte(index, 1) 'hier wird die Array.Variable verwendet
Case 0 To 0.1
.MarkerForegroundColorIndex = 6
.MarkerBackgroundColorIndex = 6
Case 0.11 To 0.2
.MarkerForegroundColorIndex = 4
.MarkerBackgroundColorIndex = 4
Case 0.21 To 0.3
.MarkerForegroundColorIndex = 10
.MarkerBackgroundColorIndex = 10
Case 0.31 To 0.4
.MarkerForegroundColorIndex = 8
.MarkerBackgroundColorIndex = 8
Case 0.41 To 0.5
.MarkerForegroundColorIndex = 5
.MarkerBackgroundColorIndex = 5
Case 0.51 To 0.6
.MarkerForegroundColorIndex = 3
.MarkerBackgroundColorIndex = 3
End Select
End With
Next index
SpeedUp (False)
End Sub
Sub Auswahl4()
SpeedUp (True)
' Auswahl in der DropDown ist "Stammhöhe astfrei"
Dim Werte
'Array-Variable zuweisen
arrWerte = Sheets("Datenübernahme").Range("F3:F" & AnzahlWerte + 2).Value
For index = 1 To AnzahlWerte
With Charts("Koordinaten Darstellung").SeriesCollection(1).Points(index)
'Farbe anhand des Eintrages in Spalte F
Select Case arrWerte(index, 1) 'hier wird die Array.Variable verwendet
Case 0 To 2
.MarkerForegroundColorIndex = 6
.MarkerBackgroundColorIndex = 6
Case 2.01 To 4
.MarkerForegroundColorIndex = 4
.MarkerBackgroundColorIndex = 4
Case 4.01 To 6
.MarkerForegroundColorIndex = 10
.MarkerBackgroundColorIndex = 10
Case 6.01 To 8
.MarkerForegroundColorIndex = 8
.MarkerBackgroundColorIndex = 8
Case 8.01 To 10
.MarkerForegroundColorIndex = 5
.MarkerBackgroundColorIndex = 5
Case 10.01 To 12
.MarkerForegroundColorIndex = 3
.MarkerBackgroundColorIndex = 3
End Select
End With
Next index
SpeedUp (False)
End Sub
Sub Auswahl5()
SpeedUp (True)
' Auswahl in der DropDown ist "Baum-Höhe in m "
Dim Werte
'Array-Variable zuweisen
arrWerte = Sheets("Datenübernahme").Range("G3:G" & AnzahlWerte + 2).Value
For index = 1 To AnzahlWerte
With Charts("Koordinaten Darstellung").SeriesCollection(1).Points(index)
'Farbe anhand des Eintrages in Spalte G
Select Case arrWerte(index, 1) 'hier wird die Array.Variable verwendet
Case 0 To 5
.MarkerForegroundColorIndex = 6
.MarkerBackgroundColorIndex = 6
Case 5.01 To 10
.MarkerForegroundColorIndex = 4
.MarkerBackgroundColorIndex = 4
Case 10.01 To 15
.MarkerForegroundColorIndex = 10
.MarkerBackgroundColorIndex = 10
Case 15.01 To 20
.MarkerForegroundColorIndex = 8
.MarkerBackgroundColorIndex = 8
Case 20.01 To 25
.MarkerForegroundColorIndex = 5
.MarkerBackgroundColorIndex = 5
Case 25.01 To 30
.MarkerForegroundColorIndex = 3
.MarkerBackgroundColorIndex = 3
End Select
End With
Next index
SpeedUp (False)
End Sub
Sub Auswahl6()
SpeedUp (True)
' Auswahl in der DropDown ist "Krohnen-Durchmesser in m"
Dim Werte
'Array-Variable zuweisen
arrWerte = Sheets("Datenübernahme").Range("H3:H" & AnzahlWerte + 2).Value
For index = 1 To AnzahlWerte
With Charts("Koordinaten Darstellung").SeriesCollection(1).Points(index)
'Farbe anhand des Eintrages in Spalte H
Select Case arrWerte(index, 1) 'hier wird die Array.Variable verwendet
Case 0 To 3
.MarkerForegroundColorIndex = 6
.MarkerBackgroundColorIndex = 6
Case 3.01 To 6
.MarkerForegroundColorIndex = 4
.MarkerBackgroundColorIndex = 4
Case 6.01 To 9
.MarkerForegroundColorIndex = 10
.MarkerBackgroundColorIndex = 10
Case 9.01 To 12
.MarkerForegroundColorIndex = 8
.MarkerBackgroundColorIndex = 8
Case 12.01 To 15
.MarkerForegroundColorIndex = 5
.MarkerBackgroundColorIndex = 5
Case 15.01 To 18
.MarkerForegroundColorIndex = 3
.MarkerBackgroundColorIndex = 3
End Select
End With
Next index
SpeedUp (False)
End Sub
Sub Auswahl7()
End Sub
Sub Auswahl8()
End Sub
Sub Auswahl9()
End Sub
Sub Auswahl10()
End Sub
Sub Auswahl11()
End Sub
Grüße aus Berlin
Peter