ja so ist es.
11.05.2009 13:45:53
Tino
Hallo,
habe den Code etwas umgebaut, Passwort musst Du noch entsprechend anpassen.
Option Explicit
Sub FormelnUndFunktionenDokumentieren()
Dim zelle As Range
Dim s As String
Dim L As Long
Dim NeuSeet As Worksheet
Dim mySH As Worksheet
Set NeuSeet = Sheets.Add(Before:=Worksheets(1))
With NeuSeet
L = 1
.Cells(L, 1).Value = "Tabelle"
.Cells(L, 2).Value = "Zelle"
.Cells(L, 3).Value = "Formel/Funktion"
.Cells(L, 4).Value = "Inhalt"
.Range("A1:D1").Font.Bold = True
L = L + 1
On Error Resume Next
For Each mySH In ThisWorkbook.Worksheets
If mySH.ProtectContents Then
mySH.Protect "Passwort", , , , True 'Passwort angeben
End If
For Each zelle In mySH.Cells.SpecialCells(xlCellTypeFormulas)
If zelle.FormulaLocal = "" Then GoTo KeineFormel: 'keine Formel in dieser Tabelle
.Cells(L, 1).Value = mySH.Name
.Cells(L, 2).Value = zelle.Address
.Cells(L, 3).Value = "'" & zelle.FormulaLocal
.Cells(L, 4).Value = zelle.Value
L = L + 1
KeineFormel: Next zelle
Next mySH
.Columns("A:D").AutoFit
End With 'NeuSeet
End Sub
'hier muss die Tabelle aktiv sein
Sub ZurückSchreiben()
Dim Bereich As Range
Dim myArea
Dim L As Long
With ActiveSheet
Set Bereich = .Range("A2:C" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
myArea = Bereich
For L = 1 To Ubound(myArea, 1)
If myArea(L, 1) <> "" Then
If Sheets(CStr(myArea(L, 1))).ProtectContents Then
Sheets(CStr(myArea(L, 1))).Protect "Passwort", , , , True 'Passwort angeben
End If
End If
If myArea(L, 1) <> "" And myArea(L, 2) <> "" And myArea(L, 3) <> "" Then
Sheets(CStr(myArea(L, 1))).Range(CStr(myArea(L, 2))).FormulaLocal = myArea(L, 3)
ElseIf myArea(L, 1) <> "" And myArea(L, 2) <> "" Then
Sheets(CStr(myArea(L, 1))).Range(CStr(myArea(L, 2))).Value = ""
End If
Next L
End Sub
Gruß Tino