Hallo Bernd,
ich habe noch einen Fehler gefunden, nimm diesen Code.
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_Open()
searchError
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub searchError()
Dim objWS As Worksheet
Dim lngR As Long, lngE As Long
Dim rng As Range, rngF As Range
Dim strFind As String, strFirst As String
On Error GoTo ErrExit
GMS
If Not SheetExist("Check") Then
ThisWorkbook.Worksheets.Add after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = "Check"
.Cells(1, 1) = "Tabelle"
.Cells(1, 2) = "Zelle"
.Cells(1, 3) = "Zellwert"
.Cells(1, 4) = "Formel"
.Cells(1, 5) = "Link"
.Rows(1).Font.Bold = True
End With
End If
With Sheets("Check")
.Range("A1").AutoFilter
.Range("A2:E" & Rows.Count).ClearContents
.Range("A2:E" & Rows.Count).Font.ColorIndex = xlAutomatic
lngR = 2
For Each objWS In ThisWorkbook.Worksheets
If Not objWS.Name = .Name Then
On Error Resume Next
Set rng = Nothing
Set rng = objWS.UsedRange.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo ErrExit
If Not rng Is Nothing Then
For Each rngF In rng
.Range(.Cells(lngR, 1), .Cells(lngR, 4)).Font.ColorIndex = 3
.Cells(lngR, 1) = objWS.Name
.Cells(lngR, 2) = rngF.Address(0, 0)
.Cells(lngR, 3) = rngF.Value
.Cells(lngR, 4) = "'" & rngF.FormulaLocal
.Hyperlinks.Add Anchor:=.Cells(lngR, 5), _
Address:="", _
SubAddress:="'" & objWS.Name & "'!" & rngF.Address, _
TextToDisplay:="Fehler!"
lngR = lngR + 1
Next
End If
End If
Next
'Textsuche
strFind = InputBox("Die Fehlerprüfung dieser Datei ist abgeschlossen." & vbLf & _
"Es wurde(n) " & CStr(lngR - 2) & " Fehler gefunden!." & vbLf & vbLf & _
"Wollen Sie auch nach Inhalten suchen?", "Errorcheck - Suche", "suchtext")
If strFind <> "Falsch" Then
lngE = lngR
For Each objWS In ThisWorkbook.Worksheets
If Not objWS.Name = .Name Then
Set rng = Nothing
strFirst = ""
Set rng = objWS.UsedRange.Find(What:=strFind, LookAt:=xlPart, LookIn:=xlValues, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False)
If Not rng Is Nothing Then
strFirst = rng.Address
Do
.Cells(lngR, 1) = objWS.Name
.Cells(lngR, 2) = rng.Address(0, 0)
.Cells(lngR, 3) = rng.Value
.Cells(lngR, 4) = "'" & rng.FormulaLocal
.Hyperlinks.Add Anchor:=.Cells(lngR, 5), _
Address:="", _
SubAddress:="'" & objWS.Name & "'!" & rng.Address, _
TextToDisplay:="Suche!"
lngR = lngR + 1
Set rng = objWS.UsedRange.FindNext(rng)
Loop While Not rng Is Nothing And strFirst <> rng.Address
End If
End If
Next
If lngR > lngE Then
MsgBox "Die Suche ergab " & CStr(lngR - lngE) & " Treffer", vbInformation, "Errorcheck - Suche"
Else
MsgBox "Die Suche ergab keine Treffer", vbInformation, "Errorcheck - Suche"
End If
End If
If lngR > 2 Then
.Activate
.Range("A1").AutoFilter Field:=5, Criteria1:="=" & IIf(lngE > 2, "Fehler!", "Suche!")
End If
End With
ErrExit:
With Err
If .Number <> 0 Then MsgBox .Number & vbLf & vbLf & .Description, vbExclamation, "Fehler"
End With
GMS True
Set objWS = Nothing
Set rng = Nothing
Set rngF = Nothing
End Sub
Private Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Gruß Sepp