AW: farbige Zellen markieren
07.06.2006 19:04:22
SteffenS
Hallo Rainer,
hier meine Schleife:
Sub zellen_planung_schuetzen()
'Änderungen aus
Application.ScreenUpdating = False
Dim pathadmin As String
pathadmin = ThisWorkbook.Path & "\"
'allgemein & Menu öffnen
If IstMappeOffen("06Menu.xls") = False Then Workbooks.Open pathadmin & "06Menu.xls", UpdateLinks:=0, Password:=Workbooks(ThisWorkbook.Name).Sheets("admin").Range("E4").Value
If IstMappeOffen("TB1.xls") = False Then Workbooks.Open pathadmin & "\TB1.xls", UpdateLinks:=0
If IstMappeOffen("06TB1.xls") = False Then Workbooks.Open pathadmin & "\06TB1.xls", UpdateLinks:=0
If IstMappeOffen("TF1.xls") = False Then Workbooks.Open pathadmin & "TF1.xls", UpdateLinks:=0
'Zellen abfragen
For Each wkb In Workbooks
If wkb.Name <> "TF1.xls" Then
For Each wks In wkb.Worksheets
If wks.Name <> "Leer" Then
wks.Unprotect (PSWDTP)
'Schutz setzen
With wks.Cells
.Locked = True
.FormulaHidden = False
End With
'schutz bei gelben zellen aufheben
For i = 1 To 60000
For j = 1 To 256
On Error Resume Next
If wkb.Sheets(wks.Name).Cells(i, j).Interior.ColorIndex = 6 Then wkb.Sheets(wks.Name).Cells(i, j).Locked = False
Next j
Next i
wks.Protect Password:=PSWDTP, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
End If
Next wks
End If
Next wkb
'Dateien schliessen und speichern
Workbooks("TB1.xls").Close savechanges:=True
Workbooks("06TB1.xls").Close savechanges:=True
Workbooks("TF1.xls").Close savechanges:=False
Workbooks("06Menu.xls").Close savechanges:=True
'Datei TB1.xls kopieren
FileCopy pathadmin & "TB1.xls", pathadmin & "tborg\TB1.xls"
'Änderungen ein
Application.ScreenUpdating = True
End Sub
Danke Dir im Voraus
Steffen Schmerler