Bezüge auf andere Blätter
19.06.2015 10:52:01
Rudi
Hallo,
optimiert:
Sub Formeln_suchen_Blatt()
'Auflistung aller Formeln mit Bezug zu einem anderen Blatt
Dim Wks As Worksheet, wksFormeln As Worksheet
Dim blnIndex As Boolean, rngF As Range, rngFormeln As Range
Dim lngZeile As Long, Kopf
Dim i As Integer, vntWks As Variant
Application.ScreenUpdating = False
blnIndex = False
lngZeile = 2
For Each Wks In Worksheets
vntWks = vntWks & Wks.Name & "!|" & "'" & Wks.Name & "'!|"
Next
vntWks = Split(vntWks, "|")
For Each Wks In Worksheets
Set rngFormeln = Nothing
On Error Resume Next
Set rngFormeln = Wks.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rngFormeln Is Nothing Then
For Each rngF In rngFormeln
For i = 0 To UBound(vntWks) - 1
If Not Replace(Replace(vntWks(i), "'", ""), "!", "") = Wks.Name Then
If InStr(rngF.FormulaLocal, vntWks(i)) Then
If blnIndex = False Then
Set wksFormeln = Worksheets.Add(after:=Sheets(Worksheets.Count))
Kopf = Array("Blatt", "Zelle", "Zeile", "Spalte", "Formel")
With wksFormeln
.Name = "ext.Formeln"
.Range("A1:E1") = Kopf
End With
blnIndex = True
End If
With wksFormeln
.Cells(lngZeile, 1) = Wks.Name
.Cells(lngZeile, 2) = rngF.Address(0, 0)
.Cells(lngZeile, 3) = rngF.Row
.Cells(lngZeile, 4) = rngF.Column
.Cells(lngZeile, 5) = "'" & rngF.FormulaLocal
.Columns.AutoFit
End With
lngZeile = lngZeile + 1
Exit For
End If
End If
Next i
Next rngF
End If
Next Wks
If blnIndex = False Then
MsgBox "Keine externen Bezüge vorhanden.", , ""
Else
wksFormeln.Activate
End If
Application.ScreenUpdating = True
End Sub
Gruß
Rudi