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)
.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"
If dic.Count > 0 Then
With .Offset(1, 0).Resize(dic.Count, 1)
.Value = WorksheetFunction.Transpose(dic.Keys)
End With
With .Offset(1, 1).Resize(dic.Count, 1)
.Value = WorksheetFunction.Transpose(dic.Items)
End With
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
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