AW: Manuelle eingabe in die zellen verhinder
16.09.2021 13:22:51
UweD
Hallo
>> Es sollen nur in den ersten 3 Spalten die Doppelcliks funktionieren und wenn etwas egal wo im Arbeitsblatt soll das wenn man in eine andere zelle geht wieder verschwinden.
Genau das macht das Makro doch
Im Codebereich von Tabelle1 steht
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If fcheck(Target) Then Cancel = True: Call TheSecretSub(Target)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not mycheck And Target.Column 1 Then
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
End If
End Sub
in Modul1
Public mycheck As Boolean
Sub TheSecretSub(rng As Range)
Dim lngRow As Long
Dim intCol As Integer
Dim lngLastRow As Long
lngRow = rng.Row
intCol = rng.Column
Range(Cells(lngRow, 2), Cells(lngRow, 4)).ClearContents
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With Range("B2:D" & lngLastRow)
.Font.Name = "Wingdings"
.Font.Size = 11
.Font.Strikethrough = False
.Font.Superscript = False
.Font.Subscript = False
.Font.OutlineFont = False
.Font.Shadow = False
.Font.Underline = xlUnderlineStyleNone
.Font.ThemeColor = xlThemeColorLight1
.Font.TintAndShade = 0
.Font.ThemeFont = xlThemeFontNone
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
mycheck = True
rng.Value = "¤"
mycheck = False
Range("A2:D" & lngLastRow).Borders.LineStyle = xlContinuous
End Sub
Function fcheck(rng As Range)
Dim lngLastRow As Long
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
If Not Intersect(rng, Range("B2:D" & lngLastRow)) Is Nothing Then fcheck = True
End Function
LG UweD