AW: Range() im Code funzt nicht
19.12.2012 09:03:35
Dave
Hallo Luschi,
der komplette Code sieht jetzt so aus:
Sub schuetzen()
Dim wks As Worksheet, KArea(1 To 5) As Range, i As Byte, FArea(1 To 25) As Range, i1 As Byte, _
i2 As Byte
Dim Area_KPMG As Range, Area_FAG As Range
Set KArea(1) = Range("BA4:BA14")
Set KArea(2) = Range("BA16:BA25")
Set KArea(3) = Range("BA28:BA30")
Set KArea(4) = Range("BA33:BA40")
Set KArea(5) = Range("BA42:BA52")
Set Area_KPMG = Union(KArea(1), KArea(2), KArea(3), KArea(4), KArea(5))
Set FArea(1) = Union(Range("C4:C14"), Range("C16:C25"), Range("C28:C30"), Range("C33:C40"), _
Range("C42:C52"))
Set FArea(2) = Union(Range("BB4:BC14"), Range("BB16:BC25"), Range("BB28:BC30"), Range("BB33: _
BC40"), Range("BB42:BC52"))
Set FArea(3) = Union(Range("BE4:BE14"), Range("BE16:BE25"), Range("BE28:BE30"), Range("BE33: _
BE40"), Range("BE42:BE52"))
Set FArea(4) = Union(Range("BG4:BH14"), Range("BG16:BH25"), Range("BG28:BH30"), Range("BG33: _
BH40"), Range("BG42:BH52"))
Set FArea(5) = Union(Range("BM4:BV14"), Range("BM16:BV25"), Range("BM28:BV30"), Range("BM33: _
BV40"), Range("BM42:BV52"))
Set Area_FAG = Union(FArea(1), FArea(2), FArea(3), FArea(4), FArea(5))
For Each wks In Worksheets
If wks.Name = "DE0O" Then 'für Testzwecke nur 1 Blatt
wks.Unprotect
i1 = wks.Protection.AllowEditRanges.Count
For i2 = 1 To i1
wks.Protection.AllowEditRanges(i2).Delete
Next i2
wks.Protection.AllowEditRanges.Add Title:="KPMG", Range:=Area_KPMG, Password:="x"
wks.Protection.AllowEditRanges.Add Title:="FAG", Range:=Area_FAG, Password:="y"
wks.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:= _
True
wks.EnableOutlining = True
End If
Next
End Sub
Das funktioniert auch grundsätzlich, so lange keine Bereiche vorher bereits definiert sind. Lasse ich den Code zweimal durchlaufen, steigt er an der Stelle
wks.Protection.AllowEditRanges(i2).Delete
aus, wenn die Variable den Wert '2' hat, das heißt, der def. Bereich "FAG" wird nicht gelöscht.
Hast du eine Idee, warum das so ist?
Gruß
Dave