AW: neue idee - neuer Versuch
14.09.2009 12:56:35
fcs
Hallo markus,
hier mal mein Machwerk.
Es fing mal ganz klein an.
1. Zell-Selektion überwachen
2. Wenn Copy-Modus-Aktiv dann über MsgBox-Werte einfügen.
3. Eingefügter Zellbereich : Locked = False
und dann kam all das drumherum um zu verhindern, dass das normale Einfügen abgefangen wird.
Die Prozeduren verfolgen jetzt permanent den SelektionsStatus und wenn "versehentlich" alles eingefügt wird, dann wird eine Undo-Aktion durchgeführt. Die Prozeduren muss du alle unter "DieseArbeitsmappe" der Datei einfügen, in der eingefügt wird. Falls du öfters leere Dateien mit dieser Funktionalität benötigst, dann solltest du eine leere Datei mit diesen Makros als Mustervorlage speichern.
Auswahlmenüs und einzelne Schaltflächen in Symbolleisten deaktivieren ist doch sehr mühselig und es muss ja beim Wechsel zwischen Dateien und beim Beenden der Datei wieder alles in den Ausgangszustand versetzt werden.
Gruß
Franz
Option Explicit
Private rngAuswahl As Range
Private Sub Workbook_Activate()
'Nach einem Wechsel von einer anderen Mappe
Set rngAuswahl = Nothing
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Fehler
Application.EnableEvents = False
Select Case Sh.Name
Case "TabelleXOX", "TabXYZ"
'In diesen Tabellen "normal" ändern
Case Else
If rngAuswahl Is Nothing Then
'Kopieren/Einfügen ohen Änderung der Zellselektion
Application.Undo 'Änderung rückgängig machen
MsgBox "Nur Einfügen von Werten ist erlaubt"
End If
End Select
Application.EnableEvents = True
Err.Clear
Fehler:
With Err
If .Number 0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
Application.CutCopyMode = False
Application.EnableEvents = True
End If
End With
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
'Nach dem Verlassen eines Blattes
Set rngAuswahl = Nothing
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Fehler
Select Case Sh.Name
Case "TabelleXOX", "TabXYZ"
'In diesen Tabellen "normal" kopieren
Case Else
CopyControl:
If rngAuswahl Is Nothing Then
'Selektion merken
Set rngAuswahl = Selection
GoTo CopyControl
Else
'Kopiervorgang kontrollieren es sollen nur Werte eingefügt werden
If Target.Row >= 1 Then 'Aktiven beeich des Makros definieren
'Überprüfung des Kopiermodus
Application.EnableEvents = False
If Application.CutCopyMode = xlCopy Then
If MsgBox("Kopierte daten als Werte einfügen?", vbQuestion + vbOKCancel, _
"Kopierte Daten als Werte einfüge") = vbOK Then
'Nur Werte einfügen
ActiveCell.PasteSpecial Paste:=xlPasteValues
'Einfügebereich entsperren
Selection.Locked = False
End If
ElseIf Application.CutCopyMode = xlCut Then
'hier ggf. verfeinern für bestimmte Zelleinfügeaktionen
ActiveCell.Insert
MsgBox "Im Ausschneide/Cut-Modus funktioniert dieses Makro nicht"
Application.CutCopyMode = False
Else
'do nothing
End If
Application.EnableEvents = True
End If
End If
End Select
Err.Clear
Fehler:
With Err
If .Number 0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
Application.CutCopyMode = False
Application.EnableEvents = True
End If
End With
End Sub
Gruß
Franz