# Fadenkreuz für alle



## usebb (14. Dezember 2008)

*Excel Fadenkreuz für alle*

Hallo  

Für alle die ein Fadenkreuz für Excel suchen hab ich da mal was gebastelt !


>>>>>  http://freenet-homepage.de/usebb/Fadenkreuz/Fk.html


MfG  usebb


----------



## Maik (14. Dezember 2008)

Fein, Fadenkreutz wird aber ohne "*t*" geschrieben 

Dementsprechend hab ich hier den Topic umbenannt.

mfg Maik


----------



## duckdonald (15. Dezember 2008)

...und guckst du hier: http://www.tutorials.de/forum/office-anwendungen/296681-excel-makro.html#7


----------



## usebb (15. Dezember 2008)

Hallo duckdonald

Jo und das ist genau so schlecht wie meiz :suspekt:

Ich suche noch  was wobei die Formatierung der Zellen bzw der Tabelle erhalten bleibt oder wieder hergestellt wird !

----------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Unprotect Password:="Dein_Passwort"

On Error Resume Next
color1 = 4     'Zeilen und Spaltenmarkierungsfarbe
color2 = 3     'Zellmarkierung
color3 = 5     'Spalten- und Zeilenüberschrift
row1 = 9     'Zeile Start >2
row2 = 27       'Zeile Ende
col1 = 14       'Spalte Start >2
col2 = 38       'Spalte Ende
Set Target = Application.Intersect(Target, Range(Cells(row1, col1), Cells(row2, col2)))
Range(Cells(row1 - 1, col1 - 1), Cells(row2, col2)).Interior.ColorIndex = xlNone
    'Bis Target markieren
Range(Cells(Target.Row, col1), Cells(Target.Row, Target.Column)).Interior.ColorIndex = color1
Range(Cells(row1, Target.Column), Cells(Target.Row, Target.Column)).Interior.ColorIndex = color1
    'Gesamte Zeile/Spalte in Target markieren
    'Range(Cells(Target.Row, col1), Cells(Target.Row, col2)).Interior.ColorIndex = color1
    'Range(Cells(row1, Target.Column), Cells(row2, Target.Column)).Interior.ColorIndex = color1
Cells(Target.Row, col1 - 1).Interior.ColorIndex = color3
Cells(row1 - 1, Target.Column).Interior.ColorIndex = color3
Cells(Target.Row, Target.Column).Interior.ColorIndex = color2
ActiveSheet.Protect Password:="Dein_Passwort", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
--------------------------------------------------------------
Kannst du mir da mal helfen ?

MfG  usebb


----------



## duckdonald (15. Dezember 2008)

. . . in der Tat, ich hab mich nochmal rangesetzt . . . .


```
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  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 = 3#
    .DashStyle = msoLineSolid
    .Style = msoLineSingle
    .Transparency = 0#
    .Visible = msoTrue
    .ForeColor.SchemeColor = 64
    .BackColor.RGB = RGB(255, 255, 255)
    .BeginArrowheadLength = msoArrowheadLengthMedium
    .BeginArrowheadWidth = msoArrowheadWidthMedium
    .BeginArrowheadStyle = msoArrowheadNone
    .EndArrowheadLength = msoArrowheadLong
    .EndArrowheadWidth = msoArrowheadWide
    .EndArrowheadStyle = msoArrowheadStealth
  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 = 3#
    .DashStyle = msoLineSolid
    .Style = msoLineSingle
    .Transparency = 0#
    .Visible = msoTrue
    .ForeColor.SchemeColor = 64
    .BackColor.RGB = RGB(255, 255, 255)
    .BeginArrowheadLength = msoArrowheadLengthMedium
    .BeginArrowheadWidth = msoArrowheadWidthMedium
    .BeginArrowheadStyle = msoArrowheadNone
    .EndArrowheadLength = msoArrowheadLong
    .EndArrowheadWidth = msoArrowheadWide
    .EndArrowheadStyle = msoArrowheadStealth
  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
```

Einfach ins Tabellenblatt einfügen wo es sein soll ;-)
Einige Zeilen zum definieren des Pfeilstils lassen sich sicher entfernen, sofern die Standardsettings passen.
Noch nicht probiert, aber ich vermute mal das der Code cversteckte (ausgeblendete) Zeilen/Spalten mitzählt - eine entsprechende Abfrage müsste dann also noch rein.

-DD-




p.s.: Code im Codeblock posten


----------



## usebb (16. Dezember 2008)

Hallo duckdonald

Der Code ist auch eine feine Sache aber ich möchte meinen behalte und nur noch verbessern !
Also so abändern, das er die Formatirung nicht entfrent .
Bei  meinen Code lassen sich die Parameter gut von einen Leihen "wie mich" einstellen .  und darum möchte ich ihn ja auch jedermann anbieten .
Aber dennoch möchte ich gleich freagen, ob ich deinen Code mit auf meiner Seite mit anbieten darf da er ja auch nicht schlecht ist.

Mfg  usebb


----------



## duckdonald (16. Dezember 2008)

Der Vorteil dieser Variante liegt halt darin das die Formatierungen garantiert erhalten bleiben, da sie garnicht erst angerührt werden.
Ein paar kleinere Eingriffe und auch hier is alles an einer Stelle anpassbar:

```
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Settings
  wght = 3# '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 = 40 '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
```


Eine Möglichkeit bei der "Zellen als Fadenkreuz"-Variante wäre es die bestehenden Formatierungen auf ein weiteres Tabellenblatt erst zu übertragen und danach das "Fadenkreuz" ausgeben. Und beim Nächsten change erst das Format von der Kopie aufs Original übertragen und dann das "Fadenkreuz" zeichnen.


-DD-


----------



## usebb (16. Dezember 2008)

Hi

Jetzt  steige ich langsam da durch !

Wenn du mir nun nach verrätzt wo mann  die X unds Y  Achse begrenzen kann ,
zum beispiel nur im bereich  von 20 D bis 30 K  soll es wirken 


Geht das auch ?


MfG


----------



## duckdonald (17. Dezember 2008)

Natürlich, dieser letzte Schritt sollte ja nun nicht allzu Kompliziert sein

```
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Settings
  wght = 3# '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 = 40 '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
  startx = 4
  endx = 11
  starty = 20
  endy = 30
'______________________________________________________________________________________
  On Error GoTo errHandler1 'Fehler abfangen
  If Not Application.Intersect(Target, Range(Cells(starty, startx), Cells(endy, endx))) Is Nothing Then
  '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
    For i = 1 To startx - 1
      x1 = x1 + Cells(1, i).Width
    Next i
    For i = 1 To starty - 1
      y1 = y1 + Cells(i, 1).Height
    Next i
    For i = startx To Cells(yy, xx).Column - 1
      x = x + Cells(1, i).Width
    Next i
    For i = starty To Cells(yy, xx).Row - 1
       y = y + Cells(i, 1).Height
    Next i
    'Zeichnen - waagerecht
    ActiveSheet.Shapes.AddLine(x1, y1 + y + Cells(yy, xx).Height / 2, x1 + x, y1 + 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(x1 + x + Cells(yy, xx).Width / 2, y1, x1 + x + Cells(yy, xx).Width / 2, y1 + 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 If
End Sub
```


-DD-



....und was ich schon länger mal sagen wollte: irgendwie glaube ich das wir beide die falschen Avatare haben


----------



## usebb (17. Dezember 2008)

Hallo 

>>>....und was ich schon länger mal sagen wollte: irgendwie glaube ich das wir beide die falschen Avatare haben  <<<

Das glaub ich nicht !  ich kenne dich nur so und ich hab das auch schon seit  ?
vielen Jahren .

Ja und den Nahmen "Donald" benutze ich ja auch noch!
>>>>http://www.carookee.com/forum/Don      zum beispiel ist aber grade beim auflösen und umbau !

Und nun zum Kreuz :  wenn es nun noch beim Drucken nicht mit auf das Blatt kommt dann kann man es gebrauchen .*gg*


MfG   Uwe


----------



## duckdonald (17. Dezember 2008)

Wie bei deiner Variante auch, einfach in die linke obere Zelle des erwählten Bereiches klicken und voilá - keine Pfeile mehr


----------



## usebb (17. Dezember 2008)

Also bei mir ist die Spitze immer sichtbar und wird auch mit gedruckt .


----------



## duckdonald (17. Dezember 2008)

usebb hat gesagt.:
			
		

> Und nun zum Kreuz : wenn es nun noch beim Drucken *nicht* mit auf das Blatt kommt dann kann man es gebrauchen .


Du erwähntest das NICHT-sehen 

OK, dann hier das Update zum Update zum Patch 


```
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Settings
  wght = 3# '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 = 40 '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
  startx = 4
  endx = 11
  starty = 20
  endy = 30
  
  pfeile = 1  '=1 Pfeile werden gezeichnet
  kreis = 1   '=1 Kreis wird gezeichnet
  'oder das letzte gesteuert aus dem Tabellenblatt:
'  pfeile = Cells(1, 1)
'  kreis = Cells(2, 1)
'______________________________________________________________________________________
  On Error Resume Next 'Fehler übergehen
  If Not Application.Intersect(Target, Range(Cells(starty, startx), Cells(endy, endx))) Is Nothing Then
  'derzeitig bekannt:
  ' # Spalten/Zeilenweise Markierung
  ' # wenn Pfeile bereits gelöscht
    
    'alte löschen
    ActiveSheet.Shapes("crossx").Delete
    ActiveSheet.Shapes("crossy").Delete
    ActiveSheet.Shapes("circle").Delete
    'aktive Zelle merken
    xx = ActiveCell.Column
    yy = ActiveCell.Row
    For i = 1 To startx - 1
      x1 = x1 + Cells(1, i).Width
    Next i
    For i = 1 To starty - 1
      y1 = y1 + Cells(i, 1).Height
    Next i
    For i = startx To Cells(yy, xx).Column - 1
      x = x + Cells(1, i).Width
    Next i
    For i = starty To Cells(yy, xx).Row - 1
       y = y + Cells(i, 1).Height
    Next i
    'Zeichnen - waagerecht
    If pfeile Then
      ActiveSheet.Shapes.AddLine(x1, y1 + y + Cells(yy, xx).Height / 2, x1 + x, y1 + 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(x1 + x + Cells(yy, xx).Width / 2, y1, x1 + x + Cells(yy, xx).Width / 2, y1 + 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"
    End If
    If kreis Then
    ActiveSheet.Shapes.AddShape(msoShapeOval, x1 + x - Cells(yy, xx).Width / 4, y1 + y - Cells(yy, xx).Height / 4, Cells(yy, xx).Width * 6 / 4, Cells(yy, xx).Height * 6 / 4).Select
    With Selection.ShapeRange
      With .Fill
        .Visible = msoFalse
        '.Solid
        .Transparency = 0#
      End With
      With .Line
        .Weight = 1.75
        .DashStyle = msoLineSolid
        .Style = msoLineSingle
        .Transparency = 0#
        .Visible = msoTrue
        .ForeColor.SchemeColor = 15
      End With
    End With
    Selection.Name = "circle"
    End If
    'alte Markierung wiederherstellen
    Cells(yy, xx).Select
  End If
End Sub
```


-DD-


----------



## usebb (17. Dezember 2008)

Hm auser das ich nun ein Kreis unm dieSpitzen habe ist nich anders.

Die Pfeile sind immer  noch beim Drucken auf den blatt !   "Sorrx"


MfG


----------



## duckdonald (17. Dezember 2008)

3x darfst du raten zuwas in den settings folgende 2 Zeilen sind:

```
pfeile = 1  '=1 Pfeile werden gezeichnet
  kreis = 1   '=1 Kreis wird gezeichnet
```

=0 würde logischerweise ein "nicht zeichnen" bedeuten


----------



## usebb (17. Dezember 2008)

Ich hab es erraten und rausgefunden !

Allerdings schon vorher das würde aber bedeuten das ich Excel unkundige erst einweisen muss damit die damit klar kommen .
Es soll ja mal ein Dienstplan werden wo Fremde die Eintragungen übernehmen müssen .
Dann soll es ja auch noch aufgereumt werden damit die arbeit ja nicht umsonst war und bei bedarf auch weitergegeben werden kann.
Somit ist diese Lösung sehr unpraktisch.

MfG


----------



## duckdonald (17. Dezember 2008)

Einstellungen lassen sich auch problemlos aus dem Tabellenblatt holen. Und/oder ein Button zum "drucken" sollte auch nicht das problem sein - in dem da hinterlegten Makro kann dann die Zelle im Sheet für die Pfeile auf "" gesetzt werden, Druckauftrag ausgelöst und wieder aktiviert werden.

-DD-


----------

