Option Explicit
 
Sub Test()
   
  Dim sh        As Excel.Worksheet
  Dim rngFails  As Excel.Range
  Dim rngMatch  As Excel.Range
  Dim rngStart  As Excel.Range
  Dim rngTarget As Excel.Range
   
  With ThisWorkbook.Worksheets("Zusammenfassung")
    Set rngStart = .Range("A5")
    Set rngTarget = rngStart
    Call .UsedRange.Clear
  End With
  
  For Each sh In ThisWorkbook.Worksheets
     
    Set rngMatch = sh.Columns("A").Find("BOARDRESULT", , xlValues, xlWhole, xlByColumns, xlNext, False)
    Set rngFails = Nothing
     
    If Not rngMatch Is Nothing Then
      If rngMatch.Offset(0, 1).Value = "FAIL" Then
        Set rngFails = sh.Range("A4", rngMatch.Offset(-2))
      End If
    End If
     
    If Not rngFails Is Nothing Then
      rngTarget.Font.Bold = True
      rngTarget.Value = sh.Name
      Call rngFails.EntireRow.Copy(Destination:=rngTarget.Offset(1))
      Set rngTarget = rngTarget.Offset(1 + rngFails.Rows.Count)
    End If
     
  Next
  
  Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
  
  With rngTarget.Worksheet.Range(rngStart, rngTarget.Offset(-1))
    For Each rngMatch In .Offset(0, 2).Cells
      If rngMatch.Value <> "" Then
        dic(rngMatch.Value) = dic(rngMatch.Value) + 1
      End If
    Next
  End With
  
  With rngTarget.Offset(1, 2)
    'Beschriftungen setzen
    .Offset(0, 1).Value = "Anzahl"
    .Offset(0, 2).Value = "relative Häufigkeit"
    .Offset(1, -1).Value = "Fehler (nur einmal):"
    .Offset(dic.Count + 1, 0).Value = "Summe"
    'Werte setzen/berechnen
    If dic.Count > 0 Then
      'Spalte mit SN
      With .Offset(1, 0).Resize(dic.Count, 1)
        .Value = WorksheetFunction.Transpose(dic.Keys)
      End With
      'Spalte: Anzahl
      With .Offset(1, 1).Resize(dic.Count, 1)
        .Value = WorksheetFunction.Transpose(dic.Items)
      End With
      'Spalte: rel. Häufigk.
      With .Offset(1, 2).Resize(dic.Count, 1)
        .NumberFormat = "0.00%"
        .Formula = "=RC[-1]/" & rngTarget.Offset(dic.Count + 2, 3).Address(ReferenceStyle:=xlR1C1)
      End With
      'Zeile: Summe
      With .Offset(dic.Count + 1, 1).Resize(1, 2)
        .Cells(2).NumberFormat = "0.00%"
        .Formula = "=SUM(R[-" & dic.Count & "]C:R[-1]C)"
      End With
      With .Resize(dic.Count + 1, 3)
        Call .Sort(.Cells(1, 3), xlAscending, Header:=xlYes)
      End With
    End If
  End With
  
  rngTarget.Worksheet.UsedRange.Columns.AutoFit
  
End Sub

Änderungen zu hier sind markiert.

Grüße