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 . . . .

Code:

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:

Code:

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

Code:

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

Fadenkreuz für alle

usebb

Mitglied

Maik

duckdonald

Erfahrenes Mitglied

usebb

Mitglied

duckdonald

Erfahrenes Mitglied

usebb

Mitglied

duckdonald

Erfahrenes Mitglied

usebb

Mitglied

duckdonald

Erfahrenes Mitglied

usebb

Mitglied

Neue Beiträge