Anzeige
Archiv - Navigation
1492to1496
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Fadenkreuz für alle Sheets und neue Datei

Fadenkreuz für alle Sheets und neue Datei
19.05.2016 15:22:18
Dieter(Drummer)
Guten Tag VBA Spezialisten,
anbei eine Musterdatei (Fadenkreuz), die auch funktioniert. Ich habe sie aus dem Internet. Hier wird aber nur das Fadenkreuz in der aktuellen Datei und im aktuellen Tabellenblatt1 realisiert. Das entsprechende Makro ist auch in Tabbellenblatt1 hinterlegt.
Mein Wunsch:
Das Fadenkreuz soll in allen Tabellenblättern der aktiven Datei UND auch in einer neu geöffneten Datei funktionieren.
Am besten wäre es, wenn ich es über die Personl.xlsb relisieren könnte, damit es in jedem Tabellenblatt, dass ich aktiviere, funktioniert.
Wie ist das machbar?
Mit der Bitte um Hilfe.
Gruß, Dieter(Drummer)
PS Die Fadenkreuzdateien von Hajo sind mir bekannt.
https://www.herber.de/bbs/user/105668.xlsm

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Fadenkreuz für alle Sheets und neue Datei
19.05.2016 15:54:59
Herbert
Hallo Dieter,
setze doch die 3 Makros in die personal.xlsb, dann hast Du sie in jeder AM zur Vfgg.
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Call FKreuz_schieben
End Sub
Dies wirst Du immer in das ClassModule der jeweiligen Tabelle kopieren müssen.
Servus

AW: Vielen Dank Herbert, das hilft schon, aber
19.05.2016 16:05:43
Dieter(Drummer)
... es gibt also nur die Möglichkeit, dass in die einzelne Tabelle, jeweils im Classenmodul, der Eintrag erfolgen muss. Das leuchtet mir ein.
Jetzt wäre es natürlich Spitze, wenn ich ein Makro in der PersonL.xlsb hätte, dass mir den Eintrag jeweils in den Classenmodulen den einzelnen Tabellen vornehmen würde. Ist das per Makro zu realisieren und wie müsste dies lauten?
Danke doch erstmal für deine Hilfe und
Gruß, Dieter(Drummer)

Anzeige
AW: Vielen Dank Herbert, das hilft schon, aber
19.05.2016 16:16:56
Daniel
Hi
nein, nicht unbedingt.
es gibt noch im Modul "DieseArbeitsmappe" das Event
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
das ist quasi ein SelectionChange-Event für alle Worksheets in der Datei, dann musst du den Code dort nur einmalig pro Datei eintragen und nicht für jedes Worksheet.
Gruß Daniel

AW: Vielen Dank Daniel für Hinweis und ...
19.05.2016 16:28:49
Dieter(Drummer)
... Rückmeldung. Die Lösung von Mullit habe ich eingesetzt und es funktioniert nach meiner Vorstellung.
Danke und einen schönen Resttag. Gruß, Dieter(Drummer)

AW: Fadenkreuz für alle Sheets und neue Datei
19.05.2016 16:04:16
Mullit
Hallo,
das geht so: in ein Standardmodul Deiner personal.xlsb fügst Du Deinen Fadenkreuz-Code ein, dann fügst Du ein neues Klassenmodul ein und benennst es in clsApplication um, dann noch folgender Code in das Modul der Arbeitsmappe Deiner personal.xlsb und in clsApplication:
' ********************************************************************** 
' Modul: DieseArbeitsmappe Typ: Klassenmodul der Arbeitsmappe 
' ********************************************************************** 

Option Explicit

Private mobjApplicationClass As clsApplication

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set mobjApplicationClass = Nothing
End Sub

Private Sub Workbook_Open()
Set mobjApplicationClass = New clsApplication
End Sub

' ********************************************************************** 
' Modul: clsApplication Typ: Klassenmodul 
' ********************************************************************** 

Option Explicit

Private WithEvents mobjApplication As Application

Private Sub Class_Initialize()
Set mobjApplication = Application
End Sub

Private Sub Class_Terminate()
Set mobjApplication = Nothing
End Sub

Private Sub mobjApplication_SheetActivate(ByVal Sh As Object)
Call FKreuz_an
End Sub

Private Sub mobjApplication_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call FKreuz_schieben
End Sub

Private Sub mobjApplication_WorkbookActivate(ByVal Wb As Workbook)
Call FKreuz_an
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 14

Gruß, Mullit

Anzeige
AW: Danke Mullit für Hilfe und Rückmeldung ...
19.05.2016 16:09:42
Dieter(Drummer)
... ich probiere es aus und melde mich wieder.
Gruß, Dieter(Drummer)

AW: Danke Mullit, klappt perfekt ...
19.05.2016 16:31:06
Dieter(Drummer)
... es funktioniert wie gewünscht.
Gruß und einen schönen Tag, Dieter(Drummer)

AW: Fadenkreuz für alle Sheets und neue Datei
19.05.2016 17:13:35
Herbert
Hallo Mullit,
was habe ich falsch gemacht, dass es bei mir nicht funzt? Ich benutze Excel 2013.
FKreuz_an und FKreuz_aus funktionieren. Nur beim Klick auf eine andere Zelle wird das FKreuz nicht angepasst.
Servus

AW: Fadenkreuz für alle Sheets und neue Datei
19.05.2016 17:32:41
Dieter(Drummer)
Hallo Herbert,
so habe ich es umgesetzt und es klappt. Hoffe Mullit verzeiht mir, dass ich darauf antworte.
In Modul1:
'******** Fadenkreuz *******
'*** Fadenkreuz 1 ***
Sub FKreuz_an()
Dim Bx As Single, By As Single, Ex As Single, Ey As Single
Dim shp As Shape
By = ActiveWindow.VisibleRange.Cells(1).Top
Bx = ActiveWindow.VisibleRange.Cells(1).Left
Ex = Selection.Left + Selection.Width / 2
Ey = Selection.Top + Selection.Height / 2
For Each shp In ActiveSheet.Shapes
If shp.Name = "F_Kreuz_X" Then Exit Sub
Next shp
'Linie in X-Richtung
Set shp = ActiveSheet.Shapes.AddLine(Bx, Ey, Ex, Ey)
With shp
.Name = "F_Kreuz_X"
.Line.Weight = 1 'Linienstärke
.Line.DashStyle = msoLineDash
.Line.ForeColor.SchemeColor = 2 'Linienfarbe
End With
'Linie in Y-Richtung
Set shp = ActiveSheet.Shapes.AddLine(Ex, By, Ex, Ey)
With shp
.Name = "F_Kreuz_Y"
.Line.Weight = 1 'Linienstärke
.Line.DashStyle = msoLineDash
.Line.ForeColor.SchemeColor = 2 'Linienfarbe
End With
End Sub '*** Fadenkreuz 2 ***
Sub FKreuz_aus()
On Error Resume Next
ActiveSheet.Shapes("f_kreuz_x").Delete
ActiveSheet.Shapes("f_kreuz_y").Delete
On Error GoTo 0
End Sub '*** Fadenkreuz 3 ***
Sub FKreuz_schieben()
Dim Bx As Single, By As Single, Ex As Single, Ey As Single
Dim shp As Shape
On Error GoTo Ende
By = ActiveWindow.VisibleRange.Cells(1).Top
Bx = ActiveWindow.VisibleRange.Cells(1).Left
Ex = Selection.Left + Selection.Width / 2
Ey = Selection.Top + Selection.Height / 2
With ActiveSheet.Shapes("f_kreuz_x")
.Top = Ey
.Left = Bx
.Width = Abs(Ex - Bx)
.Height = 0
End With
With ActiveSheet.Shapes("f_kreuz_y")
.Top = By
.Left = Ex
.Width = 0
.Height = Abs(Ey - By)
End With
Ende:
End Sub
'***** Ende Fadenkreuz ******
In diese Arbeitsmappe:
' *** Fadenkreuz ******************************************************
' Modul: DieseArbeitsmappe Typ: Klassenmodul der Arbeitsmappe
'Herber: von Mullit am 19.05.2016 16:04:16
' **********************************************************************
Private mobjApplicationClass As clsApplication
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set mobjApplicationClass = Nothing
End Sub

Private Sub Workbook_Open()
Set mobjApplicationClass = New clsApplication
End Sub
In neues neues Klassenmodul "clsApplication":
Option Explicit
' **********************************************************************
' Modul: clsApplication Typ: Klassenmodul
' **********************************************************************
Private WithEvents mobjApplication As Application
Private Sub Class_Initialize()
Set mobjApplication = Application
End Sub

Private Sub Class_Terminate()
Set mobjApplication = Nothing
End Sub

Private Sub mobjApplication_SheetActivate(ByVal Sh As Object)
Call FKreuz_an
End Sub

Private Sub mobjApplication_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call FKreuz_schieben
End Sub

Private Sub mobjApplication_WorkbookActivate(ByVal Wb As Workbook)
Call FKreuz_an
End Sub
So habe ich es angelegt nach Rückmeldung von Mullit.
Gruß, Dieter(Drummer)

Anzeige
AW: Fadenkreuz für alle Sheets und neue Datei
19.05.2016 22:05:09
Mullit
Hallo,
@ Dieter
null Problemo, gut, daß es klappt..
@ Herbert
..hmmm ich hab leider z.Zt. kein xl2013 zur Hand, dort hat sich die Fensterverwaltung geändert, kann sein, daß das ActiveWindow-Objekt in der Version anders arbeitet, aber Du kannst ja mal testweise die On Error-Anweisung rausnehmen und sehen was für ein Fehler kommt...
Ich laß nochmal offen...
Gruß, Mullit

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige