Fehler bei "Werte einfügen" in gesperrte Zellen
08.03.2017 08:10:27
H.Paul
Mein Problem ist folgendes:
In meinem Excel-Sheet (vereinfachter Nachbau eines Kundensheets) gibt es gesperrte und ungesperrte Zellen, einige davon sind verbundene Zellen (da sie Sheets schon lange gewachsen sind muss das aus optischen Gründen so bleiben).
Das Sheet habe ich "ganz normal" (Haken bei Gesperrte Zellen auswählen und Nicht gesperrte Zellen auswählen) mit Blattschutz gegen Änderungen geschützt.
Wenn ich nun eine der ungesperrten Zellen wähle und kopiere, danach eine andere ungesperrte Zelle und mit gedrückter STRG-Taste weitere Zellen (auch gesperrte) auswähle (wobei mindestens eine der gewählten Zellen eine verbundene sein muss, um den Fehler zu produzieren), dann mittels "Werte einfügen" einfüge und die folgende Fehlermeldung "Für diese Aktion müssen alle verbundenen Zellen dieselbe Größe haben" mit OK quittiere, ist der Wert aus der kopierten Zelle sowohl in den gewählten ungesperrten, als auch in den gewählten gesperrten Zellen eingetragen (Formeln, fester Text o.ä. werden überschrieben)
Das Problem tritt nur auf, wenn mindestens eine verbundene Zelle beteiligt ist!
Schematischer Nachbau zum Testen https://www.herber.de/bbs/user/111821.xlsx
Ist auch getestet unter Excel 2003, 2007 und 2010
Wenn ich im eingebauten Makro (Auszug eines ÄnderungsTrails) die Target.Adress im Debugger beobachte stelle ich fest, dass bei dem genannten Problem die Adresse nur die zuerst gewählte Zelle enthält. Bei ungebundenen Zellen oder STRG-V sind alle geänderten Zellen in Target.Adress zu finden (je nach Wahl getrennt durch ":" bzw. ",")
Makro:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' Description: Prevents locked merged cell from change
' Call: The function is called by the change event
' Input: N/A
' Output: N/A
' History:
' 01:
On Error GoTo Fehler
Dim cellArr() As String
Dim cellValNew() As String
Dim i As Long
Dim x As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
' Check if one or more cells are changed
If InStr(Target.Address(0, 0), ",") Or InStr(Target.Address(0, 0), ":") > 0 Then
' If more then one cell is updated
ReDim cellArr(0 To (Target.Cells.Count - 1))
ReDim cellValNew(0 To (Target.Cells.Count - 1))
ReDim cellValOld(0 To (Target.Cells.Count - 1))
i = 0
' For each changed cell
For Each cell In Target
cellArr(i) = cell.Address(False, False)
cellValNew(i) = cell.Value
i = i + 1
Next cell
' Undo change
Application.Undo
' For each changed cell
For x = 0 To i - 1
' Check if a value was changed
If cellValNew(x) Range(cellArr(x)).Value Then
strOld = Range(cellArr(x)).Value
' Write the new value to the cell
Range(cellArr(x)).Value = cellValNew(x)
End If
Next x
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Fehler:
exit sub
End Sub