nochmal optimiert.
06.03.2010 15:58:54
Tino
Hallo,
jetzt sollte auch =A1&"!" drin vor kommen dürfen.
Sub test()
Dim oWS As Worksheet, rngFormel As Range
Dim meAr(), ArTabellen()
Dim LCounter As Long
For Each oWS In ThisWorkbook.Worksheets
Redim Preserve ArTabellen(LCounter)
ArTabellen(LCounter) = oWS.Name & "!"
LCounter = LCounter + 1
Next oWS
LCounter = 0
For Each oWS In ThisWorkbook.Worksheets
FindFormelZellen oWS, rngFormel
If Not rngFormel Is Nothing Then
For Each rngFormel In rngFormel
If FindExternTab(ArTabellen, rngFormel.FormulaLocal, (oWS.Name & "!")) Then
LCounter = LCounter + 1
Redim Preserve meAr(1 To 3, 1 To LCounter)
meAr(1, LCounter) = oWS.Name
meAr(2, LCounter) = rngFormel.Address
meAr(3, LCounter) = "'" & rngFormel.FormulaLocal
End If
Next rngFormel
End If
Next oWS
If LCounter > 1 Then
With Worksheets.Add(ThisWorkbook.Sheets(1))
.Range("A1") = "Tabelle"
.Range("B1") = "Zelle"
.Range("C1") = "Formel"
.Range("A2").Resize(Ubound(meAr, 2), Ubound(meAr)) = Application.Transpose(meAr)
With .Range("A1:C1")
.Font.Bold = True
.EntireColumn.AutoFit
End With
End With
Else
MsgBox "keine Zelle gefunden"
End If
End Sub
Sub FindFormelZellen(ByVal oWS As Worksheet, ByRef rngZelle)
Set rngZelle = Nothing
On Error Resume Next
Set rngZelle = oWS.UsedRange.SpecialCells(xlCellTypeFormulas)
End Sub
Function FindExternTab(ArTabellen, sFormel$, aktWS$) As Boolean
Dim A As Long
For A = Lbound(ArTabellen) To Ubound(ArTabellen)
If aktWS$ <> ArTabellen(A) Then
FindExternTab = InStr(sFormel, ArTabellen(A)) > 0
If FindExternTab Then Exit Function
End If
Next A
End Function
Gruß Tino