Range() im Code funzt nicht

Sub schuetzen() Dim wks As Worksheet, Area(2) As Range, i As Byte Set Area(1) = Range("BA4:BA14") Set Area(2) = Range("BA16:BA25") For Each wks In Worksheets If wks.Name = "DE0O" Then wks.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:= _ True wks.EnableOutlining = True For i = 1 To 2 wks.Protection.AllowEditRanges.Add Title:="KPMG", Range:=Area(i), Password:="xxx" Next End If Next End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub schuetzen() Dim wks As Worksheet, Area(2) As Range, i As Byte Set Area(1) = Range("BA4:BA14") Set Area(2) = Range("BA16:BA25") For Each wks In Worksheets If wks.Name = "DE0O" Then For i = 1 To 2 wks.Protection.AllowEditRanges.Add Title:="KPMG", Range:=Area(i), Password:="xxx" Next wks.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:= _ True wks.EnableOutlining = True End If Next End Sub

Sub schuetzen() Dim wks As Worksheet, KArea(1 To 5) As Range, i As Byte, FArea(1 To 25) As Range Dim Area_KPMG As Range Set KArea(1) = Range("BA4:BA14") Set KArea(2) = Range("BA16:BA25") 'KArea(3) = ("BA28:BA30") 'KArea(4) = ("BA33:BA40") 'KArea(5) = ("BA42:BA52") Set Area_KPMG = Union(KArea(1), KArea(2)) For Each wks In Worksheets If wks.Name = "DE0O" Then wks.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:= _ True wks.EnableOutlining = True wks.Protection.AllowEditRanges.Add Title:="KPMG", Range:=Area_KPMG, Password:="xxx" End If Next End Sub

Sub schuetzen() Dim wks As Worksheet, Area(2) As Range, i1 As Integer, i2 As Integer For Each wks In Worksheets If wks.Name = "DE0O" Then Set Area(1) = wks.Range("BA4:BA14") Set Area(2) = wks.Range("BA16:BA25") wks.Unprotect "xxx" i1 = wks.Protection.AllowEditRanges.Count For i2 = 1 To i1 If wks.Protection.AllowEditRanges(i2).Title = "KPMG" Then wks.Protection.AllowEditRanges(i2).Delete End If Next i2 wks.Protection.AllowEditRanges.Add Title:="KPMG", Range:=Union(Area(1), Area(2)), _ Password:="xxx" wks.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly: _ =True wks.EnableOutlining = True End If Next End Sub

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

Hallo Dave,
so geht es auch. Ich lasse lieber die Schleife rückwärts laufen.
Außerdem habe ich die Bereichsdefinition nach unten gezogen, um Range() auf die richtige Tabelle zu referenzieren.
Sollte mal die Vba-Routine gestartet werden, ohne daß die richtige Tabelle aktiviert ist, gibt _ es wieder nur Vba-Fehler:


Dim wks As Worksheet, KArea(1 To 5) As Range, i As Byte, FArea(1 To 25) As Range, _
i1 As Integer, i2 As Integer
Dim Area_KPMG As Range, Area_FAG As Range
For Each wks In Worksheets
If wks.Name = "DE0O" Then 'für Testzwecke nur 1 Blatt
wks.Unprotect
Set KArea(1) = wks.Range("BA4:BA14"):  Set KArea(2) = wks.Range("BA16:BA25")
Set KArea(3) = wks.Range("BA28:BA30"): Set KArea(4) = wks.Range("BA33:BA40")
Set KArea(5) = wks.Range("BA42:BA52")
Set Area_KPMG = Union(KArea(1), KArea(2), KArea(3), KArea(4), KArea(5))
Set FArea(1) = Union(wks.Range("C4:C14"), wks.Range("C16:C25"), _
wks.Range("C28:C30"), wks.Range("C33:C40"), wks.Range("C42:C52"))
Set FArea(2) = Union(wks.Range("BB4:BC14"), wks.Range("BB16:BC25"), _
wks.Range("BB28:BC30"), wks.Range("BB33:BC40"), wks.Range("BB42:BC52") _
)
Set FArea(3) = Union(wks.Range("BE4:BE14"), wks.Range("BE16:BE25"), _
wks.Range("BE28:BE30"), wks.Range("BE33:BE40"), wks.Range("BE42:BE52") _
)
Set FArea(4) = Union(wks.Range("BG4:BH14"), wks.Range("BG16:BH25"), _
wks.Range("BG28:BH30"), wks.Range("BG33:BH40"), wks.Range("BG42:BH52" _
))
Set FArea(5) = Union(wks.Range("BM4:BV14"), wks.Range("BM16:BV25"), _
wks.Range("BM28:BV30"), wks.Range("BM33:BV40"), wks.Range("BM42:BV52") _
)
Set Area_FAG = Union(FArea(1), FArea(2), FArea(3), FArea(4), FArea(5))
i1 = wks.Protection.AllowEditRanges.Count
For i2 = i1 To 1 Step -1
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

Gruß von Luschi
aus klein-Paris

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread