Kopierschutz bei Datenüberprüfung

Hallo zusammen,
ich bin total neu hier und hätte ein Problem das es zu lösen gilt. :)
Ich habe ein Tabellenblatt in dem mehrere Leute arbeiten. In diesem können regelmäßig neue Zeilen und Inhalte eingefügt (kopiert) werden.
Da ich hier aber auch (teilweise verteilt) einige Dropdown-Menüs habe möchte ich diese Zellen entsprechend vor dem willkürlichen Einfügen von Daten schützen.
1. Blattschutz fällt aus da in in dem Tabellenblatt gearbeitet wird.
2. Ich habe ein einfaches Makro gefunden das den Kopiervorgang abbricht wenn eine Zelle aus dem _
definierten Bereich ausgewählt wird. Das fällt auch aus da sich im Tabellenblatt regelmäßig _ etwas verschiebt und man ständig die Bereiche neu definieren müsste.


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:C65536")) Is Nothing Then
Application.CutCopyMode = xlCopy
End If
End Sub

3. Ich weiß dass man aus Zellen auslesen lassen kann ob eine Datenüberprüfung vorliegt.
Sub test()
Dim B As Boolean
On Error Resume Next
B = Range("B3:B6").Validation.InCellDropdown
On Error GoTo 0
MsgBox IIf(B, "Vorhanden", "Nicht vorhanden")
End Sub
Jetzt zur Frage:
Hat jemand vielleicht eine fertig Lösung in Form eines Makros das:
1. Überprüft ob sich innerhalb des ausgewählten Bereiches mindestens 1 Zelle mit Datenüberprüfung befindet. Das Makro muss erkennen ob eine oder mehrere Zellen ausgewählt sind und bei Zweiterem jede einzelne Zelle nach eine Datenüberprüfung durchsuchen.
2. Wenn das der Fall ist den Kopiervorgang abbricht.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rngZelle As Range Dim B As Boolean On Error GoTo Fehler ' If Not Intersect(Target, Range("A1:C65536")) Is Nothing Then For Each rngZelle In Target.Cells B = rngZelle.Validation.InCellDropdown If B = True Then Exit For Next rngZelle If B = True Then Application.CutCopyMode = False MsgBox "Kopiervorgang wird abgebrochen" & vbLf _ & "Selekterter Zellbereich enthält Zelle(n) mit Dropdown-Auswahl" Else MsgBox "Selekterter Zellbereich enthält keine Zelle(n)" _ & "mit Dropdown-Auswahl" 'Testzeile - im Produktionsbetrieb löschen End If ' End If Fehler: With Err Select Case .Number Case 0 'alles OK Case 1004 'Tritt auf, wenn Zelle keine Datenprüfung enthält Resume Next Case Else MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description End Select End With End Sub

Hallo Christian,
hier eine Anpassung meines Makros.
1. Es wird geprüft ob der Kopiermodus aktiv ist.
Wenn ja, dann wird eine Prüfung auf Zellen mit Drop-Downprüfungen im sektierten Bereich durchgeführt.
2. Da beim Einfügen die selektierten Zellen nicht mit der der Größe des kopierten Zellbereichs übereinstimmen müssen. Hab ich den zu vergleichenden Zellbereich angepasst.
Nicht abgedeckt ist der Fall, das von einem externen Blatt aus kopiert wird - hier wird es sehr kompliziert.
Probiere mal alle Kopier-Varianten aus ob es immer korrekt funktioniert.
LG
Franz

'Code im Codemodul des Tabellenblatts
Option Explicit
Private rngCopy As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngBeich As Range, rngZelle As Range
Dim B As Boolean
On Error GoTo Fehler
'    If Not Intersect(Target, Range("A1:C65536")) Is Nothing Then
If Application.CutCopyMode  False Then
If rngCopy Is Nothing Then
'Zellen auf anderem Blatten wurden kopiert
For Each rngZelle In Target.Cells
B = rngZelle.Validation.InCellDropdown
If B = True Then Exit For
Next rngZelle
Else
'Zellen auf diesem Blatt wurden kopiert
For Each rngZelle In Range(Target.Range("A1"), _
Target.Cells(rngCopy.Rows.Count, rngCopy.Columns.Count)).Cells
B = rngZelle.Validation.InCellDropdown
If B = True Then Exit For
Next rngZelle
End If
If B = True Then
Application.CutCopyMode = False
MsgBox "Kopiervorgang wird abgebrochen" & vbLf _
& "Einfügebereich enthält Zelle(n) mit Dropdown-Auswahl"
End If
Set rngCopy = Nothing
Else
Set rngCopy = Target
End If
'    End If
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 1004 'Tritt auf, wenn Zelle keine Datenprüfung enthält
Resume Next
Case Else
MsgBox "Fehler-Nr.. " & .Number & vbLf & .Description
End Select
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Kopierschutz bei Datenüberprüfung

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread