Ausgewälte Zelle - farbig?? | HERBERS Excel Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Joachim!
Probier das mal aus!

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_Activate()
Call createLines(ActiveSheet)
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Workbook_Deactivate
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Workbook_Deactivate
End Sub

Private Sub Workbook_Deactivate()
On Error Resume Next
With ActiveSheet
  .Shapes("lineH").Delete
  .Shapes("lineV").Delete
End With
Set lineH = Nothing
Set lineV = Nothing
On Error GoTo 0
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call createLines(Sh)
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
With Sh
  .Shapes("lineH").Delete
  .Shapes("lineV").Delete
End With
On Error GoTo 0
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If lineH Is Nothing Or lineV Is Nothing Then Call createLines(Sh)
With lineH
  .Left = 0
  .Width = Sh.Cells(1, Columns.Count).Left + Sh.Cells(1, Columns.Count).Width
  .Top = Target.Top + Target.Height
End With

With lineV
  .Top = 0
  .Height = Sh.Cells(Rows.Count, 1).Top + Sh.Cells(Rows.Count, 1).Height
  .Left = Target.Left + Target.Width
End With

On Error GoTo 0
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
Option Private Module

Public lineH As Shape
Public lineV As Shape

Sub createLines(Sh As Worksheet)
With Sh
  On Error Resume Next
  .Shapes("lineH").Delete
  .Shapes("lineV").Delete
  On Error GoTo 0

  Set lineH = .Shapes.AddLine(0, 0, 0, 0)

  With lineH
    .Name = "lineH"
    .Line.Weight = 1#
    .Line.ForeColor.SchemeColor = 10
    .Left = 0
    .Width = Sh.Cells(1, Columns.Count).Left + Sh.Cells(1, Columns.Count).Width
    .Top = ActiveCell.Top + ActiveCell.Height
    .OnAction = "dmy"
  End With

  Set lineV = .Shapes.AddLine(0, 0, 0, 0)

  With lineV
    .Name = "lineV"
    .Line.Weight = 1#
    .Line.ForeColor.SchemeColor = 10
    .Top = 0
    .Height = Sh.Cells(Rows.Count, 1).Top + Sh.Cells(Rows.Count, 1).Height
    .Left = ActiveCell.Left + ActiveCell.Width
    .OnAction = "dmy"
  End With

End With

End Sub

Public Sub dmy()

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Joachim!
Bei geschützten Tabellen, wirst du evtl. nach dem Passwort gefragt.
Anders geht's nicht.
Beim Drucken werden die Linien gelöscht!
Im Zellkontextmenü, kannst du die Linien Ein- und Aus-Schalten.

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

'---------------------------------------------------------------------------------------
' Module : DieseArbeitsmappe
' DateTime : 21.01.2006 00:36
' Author : Josef Ehrensberger
' Purpose : Fadenkreuz in Tabelle
'---------------------------------------------------------------------------------------

Option Explicit

Private Sub Workbook_Activate()
Call addContext
Call createLines(ActiveSheet)
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Workbook_Deactivate
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Workbook_Deactivate
End Sub

Private Sub Workbook_Deactivate()
On Error Resume Next
Application.CommandBars("Cell").FindControl(Tag:="CellHigh").Delete
On Error GoTo 0
delLines ActiveSheet
End Sub

Private Sub Workbook_SheetActivate(ByVal sh As Object)
Call createLines(sh)
End Sub

Private Sub Workbook_SheetDeactivate(ByVal sh As Object)
On Error Resume Next
With sh
  .Shapes("lineH").Delete
  .Shapes("lineV").Delete
End With
On Error GoTo 0
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
On Error Resume Next
If Not bAction Then Exit Sub
If lineH Is Nothing Or lineV Is Nothing Then Call createLines(sh)
With lineH
  .Top = Target.Top + Target.Height
End With

With lineV
  .Left = Target.Left + Target.Width
End With

On Error GoTo 0
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

'---------------------------------------------------------------------------------------
' Module : Modul1
' DateTime : 21.01.2006 00:38
' Author : Josef Ehrensberger
' Purpose : Fadenkreuz in Tabelle
'---------------------------------------------------------------------------------------
Option Explicit
Option Private Module

Public lineH As Shape
Public lineV As Shape
Public bAction As Boolean

Sub createLines(sh As Worksheet)

If Not bAction Then Exit Sub

With sh

  If .ProtectDrawingObjects Then .Protect userinterfaceonly:=True, DrawingObjects:=False

  delLines sh

  Set lineH = .Shapes.AddLine(0, 0, 0, 0)

  With lineH
    .Name = "lineH"
    .Line.Weight = 1#
    .Line.ForeColor.SchemeColor = 10
    .Left = 0
    .Width = sh.Cells(1, Columns.Count).Left + sh.Cells(1, Columns.Count).Width
    .Top = ActiveCell.Top + ActiveCell.Height
    .OnAction = "dmy"
  End With

  Set lineV = .Shapes.AddLine(0, 0, 0, 0)

  With lineV
    .Name = "lineV"
    .Line.Weight = 1#
    .Line.ForeColor.SchemeColor = 10
    .Top = 0
    .Height = sh.Cells(Rows.Count, 1).Top + sh.Cells(Rows.Count, 1).Height
    .Left = ActiveCell.Left + ActiveCell.Width
    .OnAction = "dmy"
  End With

End With

End Sub

Sub delLines(sh As Worksheet)
With sh
  On Error Resume Next
  .Shapes("lineH").Delete
  .Shapes("lineV").Delete
  On Error GoTo 0
End With
Set lineH = Nothing
Set lineV = Nothing
End Sub

Public Sub dmy()

End Sub

Sub addContext()
Dim objCBB As CommandBarButton

With Application.CommandBars("Cell")

  On Error Resume Next
  .FindControl(Tag:="CellHigh").Delete
  On Error GoTo 0

  Set objCBB = .Controls.Add(Type:=msoControlButton, Temporary:=True)

  With objCBB
    .Caption = IIf(bAction, "CellHighLighter Aus", "CellHighLighter Ein")
    .Style = msoButtonIconAndCaption
    .Tag = "CellHigh"
    .OnAction = "HiLitOnOff"
    .FaceId = IIf(bAction, 342, 352)
    .BeginGroup = True
  End With

End With

Set objCBB = Nothing

End Sub

Private Sub HiLitOnOff()
With Application.CommandBars.ActionControl
  If Application.CommandBars.ActionControl.Caption = "CellHighLighter Aus" Then
    bAction = False
    .Caption = "CellHighLighter Ein"
    .FaceId = 352
    delLines ActiveSheet
  Else
    bAction = True
    .Caption = "CellHighLighter Aus"
    .FaceId = 342
    createLines ActiveSheet
  End If
End With
End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) ActiveSheet.Unprotect ("passwort") Static Zelle As Range If Not Zelle Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 6 ' Grün Set Zelle = Target ActiveSheet.Protect ("passwort") End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Static Zelle As Range If Not Zelle Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 4 ' Grün Set Zelle = Target End Sub

Beliebteste Forumthreads (12 Monate)

Ausgewälte Zelle - farbig??

31 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

31
Beiträge zum Forumthread

Beiträge zu diesem Forumthread