VBA Code mit Button ein und ausschalten
14.08.2019 11:05:01
Krogi
ich möchte gerne folgenden unten gezeigten Code (Fadenkreuz-Übersicht für große Tabellen) über eine Schaltfläche (also einen Button anlegen) ein- und ausschalten können, da die Funktion nicht immer benötigt wird.
Ich bin Laie... und kriegs nicht hin. Ich hoffe auf Hilfe und bedanke mich im Voraus für jeden Hinweis.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Settings
wght = 2# 'Linienstärke in Punkt
DS = msoLineSquareDot 'linienart
'möglich sind:
' msoLineDash 'gestrichelt
' msoLineDashDot 'strichpunkt
' msoLineDashDotDot 'strichpunktpunkt
' msoLineRoundDot 'runde punkte
' msoLineSolid 'durchgehende Linie
' msoLineSquareDot 'eckige Punkte
FC = 23 'Farbe der Linie
' 64=schwarz
' 1=weiss
' 2=rot
' 3=grün
' 4=blau
EAL = msoArrowheadLong 'Pfeilkopflänge
'möglich sind:
' msoArrowheadShort 'kurz
' msoArrowheadLengthMedium 'mittel
' msoArrowheadLong 'lang
EAW = msoArrowheadWide 'Pfeilkopfbreite
'möglich sind:
' msoArrowheadNarrow 'dünn
' msoArrowheadWidthMedium 'mittel
' msoArrowheadWide 'dick
EAS = msoArrowheadStealth 'Pfeilkopfstil
'möglich sind:
' msoArrowheadNone 'keiner
' msoArrowheadOval 'oval
' msoArrowheadDiamond 'diamantform
' msoArrowheadOpen 'offener Kopf
' msoArrowheadStealth 'hinten spitz
' msoArrowheadTriangle 'dreieckig
'______________________________________________________________________________________
On Error GoTo errHandler1 'Fehler abfangen
'derzeitig bekannt:
' # Spalten/Zeilenweise Markierung
' # wenn Pfeile bereits gelöscht
'alte löschen
ActiveSheet.Shapes("crossx").Delete
ActiveSheet.Shapes("crossy").Delete
errHandler1:
'entweder weiter die Fehler behandeln und ausgeben oder einfach nix weiter machen :)
On Error GoTo errHandler2 'Fehler abfangen
'aktive Zelle merken
xx = ActiveCell.Column
yy = ActiveCell.Row
x = 0
y = 0
For i = 1 To Cells(yy, xx).Column - 1
x = x + Cells(1, i).Width
Next i
For i = 1 To Cells(yy, xx).Row - 1
y = y + Cells(i, 1).Height
Next i
'Zeichnen - waagerecht
ActiveSheet.Shapes.AddLine(0, y + Cells(yy, xx).Height / 2, x, y + Cells(yy, xx).Height / 2). _
_
_
Select
With Selection.ShapeRange.Line
.Weight = wght
.DashStyle = DS
.ForeColor.SchemeColor = FC
.BackColor.RGB = RGB(BCr, BCg, BCb)
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadLength = EAL
.EndArrowheadWidth = EAW
.EndArrowheadStyle = EAS
End With
Selection.Name = "crossx"
'zeichnen - senkrecht
ActiveSheet.Shapes.AddLine(x + Cells(yy, xx).Width / 2, 0, x + Cells(yy, xx).Width / 2, y). _
Select
With Selection.ShapeRange.Line
.Weight = wght
.DashStyle = DS
.ForeColor.SchemeColor = FC
.BackColor.RGB = RGB(BCr, BCg, BCb)
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadLength = EAL
.EndArrowheadWidth = EAW
.EndArrowheadStyle = EAS
End With
Selection.Name = "crossy"
'alte Markierung wiederherstellen
Cells(yy, xx).Select
errHandler2:
'entweder weiter die Fehler behandeln und ausgeben oder einfach nix weiter machen :)
End Sub
Anzeige