Fadenkreuz für alle

[duckdonald]

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

 

[usebb]

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

 

[duckdonald]

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]

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]

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]

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]

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-