VBA-Beispiel 146
mail schreiben
mail schreiben

fehlerhafte Formeln auflisten

In einer eigenen Tabelle sollen alle fehlerhaften Formeln der Datei aufgelistet werden. Für jede Fundstelle erfolgen in der Fehlerliste drei Einträge: die Zelladress als Hyperlink, Text der Zelle (die Fehlermeldung) und die Formel.
        
        
Private Function AnzahlFehlerformeln(ByVal wkb As Workbook) As Long     
Dim wks As Worksheet  
Dim lngAnz As Long   
' + ------------------------------------------------------ +
'   liefert die Gesamtanzahl aller Fehlerwerte eine Mappe
' + ------------------------------------------------------ +

On Error Resume Next    
  For Each wks In wkb.Worksheets   
    lngAnz = lngAnz + _
             wks.Cells.SpecialCells(xlCellTypeFormulas, 16).Count 
  Next wks 
On Error GoTo 0    

  AnzahlFehlerformeln = lngAnz
End Function  

Public Sub Fehlerliste()  
Dim wks As Worksheet, wksF As Worksheet  
Dim bolTab As Boolean   
Dim z As Range, rngF As Range   
Dim lngZ As Long, lngAnz As Long   
Dim arr 
Dim xlsCalc As XlCalculation  
Dim strDatei As String, strTab As String, strZ As String    

' + ------------------------------------- +
'   alle Fehlerwerte einer Arbeitsmappe
'   in einer separaten Tabelle auflisten
' + ------------------------------------- +

On Error GoTo Hell    
  lngAnz = AnzahlFehlerformeln(ThisWorkbook)
  
  'Ende wenn null Fehler
  If lngAnz = 0 Then  
    MsgBox "Keine fehlerhaften Formeln vorhanden!", _ 
            vbInformation, "Programmende:" 
    Exit Sub  
  End If  
  
  'auf alte Fehlerliste prüfen
  For Each wks In ThisWorkbook.Worksheets   
    If wks.CodeName = "wksFehler" Then  
      wks.Activate
      
      'wg löschen nachfragen
      If MsgBox("Soll die alte Fehlerliste gelöscht werden?", _ 
                vbOKCancel, "") = vbOK Then 
        bolTab = True 
        Set wksF = wks 
        wksF.Cells.Clear
        Exit For  
      Else 
        Exit Sub  
      End If  

    End If  
  Next wks 
  
  'sonst neue Fehlerliste anlegen
  If bolTab = False Then   
    Set wksF = ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count)) 
    wksF.Name = "Fehlerliste"

    'falls der Editor noch nicht sichtbar war,
    'würde es zu einer Fehlermeldung kommen.
    On Error Resume Next    
    Application.ScreenUpdating = False 
    Application.VBE.MainWindow.Visible = True 
    ThisWorkbook.VBProject.VBComponents(wksF.CodeName) _
                  .Properties("_CodeName").Value = "wksFehler"
    Application.VBE.MainWindow.Visible = False 
    Application.ScreenUpdating = True 
    On Error GoTo Hell    
  End If  
    
  lngZ = 1
  arr = Array("Address", "Text", "Formel") 
  strDatei = "[" & ThisWorkbook.Name & "]" 
  xlsCalc = Application.Calculation   'Einstellung merken
  
  Application.Calculation = xlCalculationManual
  
  For Each wks In ThisWorkbook.Worksheets   
    If wks.CodeName <> wksF.CodeName Then  
      
      Set rngF = Nothing   
      
      'wäre Fehler 1004 wenn keine Zellen gefunden:
      On Error Resume Next    
        Set rngF = wks.Cells.SpecialCells(xlCellTypeFormulas, 16)  
      On Error GoTo 0    

      If Not rngF Is Nothing Then     
        For Each z In rngF   
          lngZ = lngZ + 1
          strTab = "'" & wks.Name & "'!"
          strZ = z.Address(False, False) 

          wksF.Cells(lngZ, 2).Formula = _ 
                        "=HYPERLINK(""" & strDatei & strTab & strZ & """," _ 
                        & """" & wks.Name & "   " & strZ & """)"
          wksF.Cells(lngZ, 3) = z.Text
          wksF.Cells(lngZ, 4) = "   " & z.Formula 
          'wksF.Hyperlinks.Add Anchor:=wksF.Cells(lngZ, 2), _
                              Address:="", _
                              SubAddress:=wks.Name & "!" & z.Address, _ 
                              TextToDisplay:=wks.Name & "!" & z.Address 
          Application.StatusBar = "Formel: " & Format(lngZ, "#,##0") & _ 
                                  " von " & Format(lngAnz, "#,##0") 
        Next z 
      End If   'rngF
      
    End If   'CodeName
  Next wks 
  
  Application.StatusBar = False 
  
  With wksF 
    With .Range("B1:D1")  
      .Value = arr
      .Font.Bold = True 
      .Interior.ColorIndex = 36 
    End With  
    
    With .Columns(2) 
      .Font.Underline = xlUnderlineStyleNone
      .EntireColumn.AutoFit
    End With  
  End With  
 
  MsgBox Format(lngZ - 1, "#,##0") & _ 
         " fehlerhafte Formeln gefunden und eingetragen!", _ 
         vbInformation, "" 
         
  Application.Calculation = xlsCalc
  Set wksF = Nothing   
  Set rngF = Nothing   
  Erase arr 
Exit Sub  

Hell:
  MsgBox "Es ist ein Fehler aufgetreten:" & vbNewLine & vbNewLine & _ 
         "F-Nr.: " & Err.Number & vbNewLine & _ 
         "F-Beschreibung: " & Err.Description, vbCritical, "uh..."
End Sub  


Download:   vba146.zip