Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1340to1344
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

VBA Beispiele Fadenkreuz

VBA Beispiele Fadenkreuz
22.12.2013 13:57:31
Andreas
Hallo Excelgemeinde,
in den Excelbeispielen habe ich diese super Lösung für das Anzeigen eines Fadenkreuzes in einer Exceltabelle gefunden:
http://hajo-excel.de/vba_markieren_fadenkreuz.htm
Funktioniert auch super, aber ich habe noch 2 Probleme:
1. Ich möchte, dass das Fadenkreuz nur im Blatt "Urlaubsliste" angezeigt wird
2. Über zwei Buttons sortiere ich verschiedene Spalten, wie kann ich das Fadenkreuz automatisch ausschalten, bevor ich sortiere?
Hier der code für die Sortierung:

Option Private Module
Sub SortierNamen()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="Test"
ActiveSheet.Range("A3:IT46").Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A3").Select
ActiveSheet.Protect Password:="Test"
Application.ScreenUpdating = True
End Sub
Hier der Code für das Fadenkreuz:
DieseArbeitsmappe:

Option Explicit                                     ' Variablendefinition erforderlich
'* H. Ziplies                                     *
'* 17.10.2013                                     *
'* erstellt von HajoZiplies@web.de                *
'* http://Hajo-Excel.de/
Private Sub Workbook_Open()
' Variable setzen damit keine Kennzeichnung bei Open
InI = 32000
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
' Auswahl einer Zelle in allen Tabellen
If BoAktion = False Then
zurueck                                     ' Farben zurueckstellen
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
' Farben des Fadenkreuzes auslesen
If TypeName(ActiveSheet) = "Worksheet" Then
' von Nepumuk Anzahl der Zellen
If CallByName(Selection, IIf(Val( _
Application.Version) > 11, "CountLarge", "Count"), VbGet) = 1 Then
' Zellen des Fadenkreuzes auslesen
Auslesen                            ' Farbe auslesen
End If
End If
End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If BoAktion = False Then
' nach Hinweis von Peter Haserodt Vergleich eingefügt
' Farben des Fadenkreuzes auslesen
If TypeName(ActiveSheet) = "Worksheet" Then
' von Nepumuk Anzahl der Zellen
If CallByName(Selection, IIf(Val( _
Application.Version) > 11, "CountLarge", "Count"), VbGet) = 1 Then
' Zellen des Fadenkreuzes auslesen
Auslesen
End If
End If
End If
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
'nach Hinweis von Peter Haserodt Vergleich eingefügt
If BoAktion = False And TypeName(ActiveSheet) = "Worksheet" Then
zurueck                                     ' Farbe zurueckstellen
End If
End Sub
Private Sub Workbook_Activate()
' Damit keine Markierung beim öffnen
If InI  32000 Then
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" And BoAktion = False Then
' von Nepumuk Anzahl der Zellen
If CallByName(Selection, IIf(Val( _
Application.Version) > 11, "CountLarge", "Count"), VbGet) = 1 Then
' Zellen Fadenkreuz auslesen
Auslesen                            ' Farbe auslesen
End If
End If
End If
End Sub
Private Sub Workbook_Deactivate()
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If BoAktion = False And TypeName(ActiveSheet) = "Worksheet" Then
zurueck                                     ' Farben zurueckstellen
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If BoAktion = False And TypeName(ActiveSheet) = "Worksheet" Then
zurueck                                     ' Farben zurueckstellen
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If BoAktion = False And TypeName(ActiveSheet) = "Worksheet" Then
zurueck                                     ' Farben zurueckstellen
End If
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
' falls Farbe beim Druck wieder zurueckgestellt werden soll
' nach Druck ist nichts markiert
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If BoAktion = False And TypeName(ActiveSheet) = "Worksheet" Then
zurueck                                     ' Farbe zurueckstellen
End If
End Sub
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
' Prüfung ob Markierung im Code eingeschaltet
If BoSpalte Or BoZeileMarkieren Or BoZelleMarkieren Then
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" And BoAktion = False Then
zurueck                                     ' Farbe zurueckstellen
End If
BoAktion = Not BoAktion                         ' Markierungszustand umschalten
If BoAktion = False Then
Auslesen                                    ' Zellen Fadenkreuz auslesen
Cancel = True                               ' Cursor in Zelle entfernen
Else
MsgBox "Markierung aus"                     ' Markierzung aus
Cancel = True                               ' Cursor in Zelle entfernen
End If
End If
End Sub
Modul: mdl_Fadenkreuz

Option Explicit                                     ' Variablendefinition erforderlich
Option Private Module                               ' damit Makros nicht unter Makros angezeigt  _
werden
'* H. Ziplies                                     *
'* 17.10.2013                                     *
'* erstellt von HajoZiplies@web.de                *
'* http://Hajo-Excel.de/
' Zeile, Spalte markieren
' alte Farbe wieder zurueckstellen bei wechsel und schliessen
' Farbveränderungen im markiertem Bereich werden nicht zurueck gestellt, verschieden von  _
Markierungsfarbe
' Abschalten durch Doppelklick
' Merker ob Markierung eingeschaltet, geschieht durch Doppelklick
' Modifiziert von JFreudens
' Durch Auswertung von Activewindow.ActivePane.VisibleRange
' wird der Aufwand deutlich reduziert. Es wird jetzt ein "Fadenkreuz" eingefärbt
Public BoAktion As Boolean                          ' Zustand der Markierung
Public StName As String                             ' CodeName der Tabelle
Public StWert() As String                           ' Zelladresse
' Dimensionierung erfolgt später in Abhängigkeit der
' Anzahl der sichtbaren Zellen des Fadenkreuzes
Public InI As Integer                               ' Schleifenvariable
Public DoFarbe As Double                            ' Farbe Markierung
Public RaFadenKreuz As Range                        ' Bereich Fadenkreuz
Public Const BoSpalte As Boolean = True             ' Spalten markieren
Public Const BoZeileMarkieren As Boolean = True     ' Zeile markieren
Public Const BoZelleMarkieren As Boolean = True     ' Zelle markieren
Public Const Bofarbe As Boolean = False             ' alle Zellen markieren False Nein, True Ja
Public BoMarkieren As Boolean                       ' Kennzeichen Markierung
Public DoFarbeEinzeln As Double                     ' Farbe einzelne Zelle
Sub zurueck()
Dim StKlarname As String                        ' Variable Klarname der Tabelle
Dim LoPattern As Long                           ' Variable Farbe des Musters
Dim LoMuster As Long                            ' Variable Muster
Dim WsTabelle As Worksheet                      ' Variable Tabelle
' es sind keine Werte vorhanden
If StName  "" Then
' Klarname der Tabellle feststellen, Schleife über alle Tabellen
For Each WsTabelle In ThisWorkbook.Worksheets
If WsTabelle.CodeName = StName Then     ' Namen mit abgespeicherten vergleichen
StKlarname = WsTabelle.Name         ' Namen auf Register auslesen
Exit For                            ' Schleife verlassen
End If
Next WsTabelle
If StKlarname = "" Then                     ' Tabelle wurde gelöscht
' ersten vorhanden Wert löschen, die Werte werden nicht mehr benötigt
StWert(0) = ""
Else
' Farbe zurueckstellen
If Not RaFadenKreuz Is Nothing Then
With ThisWorkbook.Worksheets(StKlarname)
.Unprotect Password:="Test"
If StWert(0, 0)  "" Then
For InI = 0 To UBound(StWert(), 2)
With .Range(StWert(0, InI)).Interior
If .ColorIndex = DoFarbe Then
If BoSpalte = False And BoZeileMarkieren = False And  _
BoZelleMarkieren Then
If DoFarbeEinzeln = 16777215 Then
.ColorIndex = xlNone
Else
.Color = DoFarbeEinzeln
End If
Else
If .Pattern = xlSolid Then
If StWert(1, InI) = 16777215 Then
.ColorIndex = xlNone
Else
.Color = StWert(1, InI)
End If
Else
LoPattern = .PatternColor
LoMuster = .Pattern
If StWert(1, InI) = 16777215 Then
.ColorIndex = xlNone
Else
.Color = StWert(1, InI)
End If
.PatternColor = LoPattern
.Pattern = LoMuster
End If
End If
End If
End With
Next InI
End If
.Protect Password:="Test"
End With
End If
End If
End If
End Sub
Sub Auslesen()
Dim RaZelle As Range                            ' Variable für Zelle
Dim StSichtbar_range As String                  ' Sichtbarer Bereich Fixierung unten rechts
Dim LoLetzte As Long                            ' Letzte Zeile Bildschirm
Dim StLinks As String                           ' linke Begrenzung Bildschirm bei Fixierung
Dim StRechts As String                          ' rechte Begrenzung Bildschirm
Dim LoPattern As Long                           ' Farbe des Musters
Dim LoMuster As Long                            ' Muster
' jede Tabelle mit einer anderen Farbe von Farbindex 3 bis 53, falls nur eine hier festen  _
Wert 3 bis 53 eintragen
DoFarbe = ActiveSheet.Index Mod 53
StName = ActiveSheet.CodeName                   ' CodeName der Tabelle
' Bestimmt den Fadenkreuz-Bereich, der durch die aktive Zelle definiert wird.
' Anschließend wird der Bereich beschnitten, um nur die Zellen des Fadenkreuzes zu behalten, _
' die derzeit sichtbar sind
Set RaFadenKreuz = Intersect(Union(ActiveCell.EntireRow, ActiveCell.EntireColumn), _
ActiveWindow.ActivePane.VisibleRange)
' Tabelle fixiert Zellen im restlichen Bereich feststellen
If ActiveWindow.FreezePanes Then                ' Tabelle ist fixiert
' Der Code zur Ermttlung der Zeile oder Spalten wurde von André (Schauan) erstellt
StSichtbar_range = ActiveWindow.ActivePane.VisibleRange.Address(True, False)
' Ansatz von Uwe Küstner ohne Vergleich
' Überprüfung ob Spalte fixiert
If ActiveWindow.SplitColumn  0 Then
If RaFadenKreuz Is Nothing Then
Set RaFadenKreuz = Range(Cells(ActiveCell.Row, 1), _
Cells(ActiveCell.Row, ActiveWindow.SplitColumn))
Else
Set RaFadenKreuz = Union(RaFadenKreuz, _
Range(Cells(ActiveCell.Row, 1), _
Cells(ActiveCell.Row, ActiveWindow.SplitColumn)))
End If
End If
' Überprüfung ob Zeile fixiert
If ActiveWindow.SplitRow  0 Then
If RaFadenKreuz Is Nothing Then
Set RaFadenKreuz = Range(Cells(1, ActiveCell.Column), _
Cells(ActiveWindow.SplitRow, ActiveCell.Column))
Else
Set RaFadenKreuz = Union(RaFadenKreuz, _
Range(Cells(1, ActiveCell.Column), _
Cells(ActiveWindow.SplitRow, ActiveCell.Column)))
End If
End If
If ActiveCell.Column  ActiveWindow.SplitRow Then
' Zelle in den Fenstern unten Links der Fixierung
' Der Code zur Ermttlung der Zeile oder Spalten
' wurde von André (Schauan) erstellt
' Ermittlung der untersten Zeile des Bildsachirms
' Unterste Zeile des sichbaren Bereiches unten
LoLetzte = ActiveWindow.ActivePane.VisibleRange.Row + _
ActiveWindow.ActivePane.VisibleRange.Rows.Count - 1
Set RaFadenKreuz = Union(RaFadenKreuz, _
Range(Cells(ActiveWindow.ActivePane.VisibleRange.Row, _
ActiveCell.Column), Cells(LoLetzte, ActiveCell.Column)))
ElseIf ActiveCell.Column > ActiveWindow.SplitColumn And _
ActiveCell.Row  DoFarbe Then
BoMarkieren = True              ' Markierung der Zelle
DoFarbeEinzeln = ActiveCell.Interior.Color
Else
BoMarkieren = False             ' keine Markierung der Zelle
End If
Else
BoMarkieren = False                 ' keine Markierung, da nichts ausgewählt
End If
If BoMarkieren Then
' Array dimensionieren, Werte bleiben erhalten
ReDim Preserve StWert(0 To 1, 0 To InI)
StWert(0, InI) = .Address
StWert(1, InI) = .Interior.Color
If BoSpalte = False And BoZeileMarkieren = False And BoZelleMarkieren Then
.Interior.ColorIndex = DoFarbe
Else
If Bofarbe Then
.Interior.ColorIndex = DoFarbe
Else
If .Interior.ColorIndex = xlNone Then .Interior.ColorIndex = DoFarbe
End If
End If
InI = InI + 1                       ' neue Array Grenze setzen
End If
End With
Next RaZelle
ActiveSheet.Protect Password:="Test"
End Sub
Kann mir bitte Jemand helfen!
Danke fürs lesen und die Hilfe!
mfg, Andreas

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Beispiele Fadenkreuz
22.12.2013 16:39:39
Hajo_Zi
Hallo Andreas,
teil 2
BoAktion = Not BoAktion
oder Doppelclick
If TypeName(ActiveSheet) = "Worksheet" and (ActiveSheet.name="Urlaubsliste" Then
an allen Stellen wo es steht.

AW: VBA Beispiele Fadenkreuz
22.12.2013 18:13:24
Andreas
Hallo Hajo,
danke für die Anwort und Hilfe. Allerdings verstehe ich nicht ganz was ich ändern soll. Ich habe jetzt im Code (DieseArbeitsmappe) überall wo

And TypeName(ActiveSheet) = "Worksheet"
stand

And TypeName(ActiveSheet) = "Worksheet" And (ActiveSheet.Name = "Urlaubsliste")
geschrieben.
Das Fadenkreuz wird aber trotzdem in allen Tabellen ausgeführt.
Und wo mus ich "BoAktion = Not BoAktion" eintragen?
Danke für die Hilfe!
mfg, Andreas

Anzeige
AW: VBA Beispiele Fadenkreuz
22.12.2013 18:29:53
Andreas
Und noch eine Frage habe ich. Betrifft das auch meine Frage bezüglich des sortierens?
mfg, Andreas

AW: VBA Beispiele Fadenkreuz
23.12.2013 09:10:28
Hajo_Zi
Hallo Andreas,
im ersten Beitrag Stand
2. Über zwei Buttons sortiere ich verschiedene Spalten, wie kann ich das Fadenkreuz automatisch ausschalten

Ich hatte daraus gelesen das dies über VBA passiert, also hätte ich das nach der Zeile Sub und vor der Zeile End Sub es geschrieben.
Ich bin im Urlaub und an einem Notrechner. Ich baue grundsätzlich keine Datei nach.
Gruß Hajo

Anzeige
AW: VBA Beispiele Fadenkreuz
23.12.2013 09:42:26
Andreas
Hallo Hajo,
vielen Dank für die Antwort und Hilfe, jetzt habe ich es verstanden. Klappt.
Einen schönen Urlaub und schöne Feiertage.
mfg, Andreas

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige