Lijst doorzoeken en matchen

[Utrecht12345]

Beste deskundigen, wie kan met een oplossing komen voor layout-formules etc.

Ik moet gegevens van gevonden voorwerpen registreren en uiteindelijk herleiden naar de eigenaar.
Als voorbeeld 4 tab bladen met Boeken-speelgoed-telefoon-brillen.
in de 1e kolom de LOST - Found- aanduiding en als er een match is als keuze wanner er 2 regels overeen komen, maar dit moet dan wel handmatig.

Wat ik eigenlijk zoek is of het mogelijk is dat de regel LOST vergeleken kan komen met de FOUND regel en indien er genoeg overeenkomsten zijn.(bij elkaar gezet worden?) en uiteindelijk in het tab blad MATCh een percentage komt (automatisch) waarin het aantal komt wat opgelost is (herleid naar eigenaar)

Je moet voorstellen dat deze lijsten wel 300 rijen per soort lang kan worden en dan is het handmatig zoeken naar een overeenkomt erg lastig en tijdrovend. Dus als er een Match is met genoeg overeenkomst zou het mooi zijn als deze dan gemarkeerd worden en met een soort "drukknop" om de zoek actie te starten in de lijst.

En als er een Match is van 2 regels, is het dan mogelijk om die 2 regels ook weer via een "drukknop" commando naar een apart Tabblad MATCHES TOTAAL te verhuizen.?
Ik hoop dat ik een beetje duidelijk ben....
zie ook de bijlage, bij voorbaat dank voor het denkwerk..

 

[HSV]

Hang het aan een knopje, druk erop en kijk in "Match %" of dit wat helpt.

Sub hsv()
Dim sv, arr, c As Range, i As Long, sh As Worksheet, firstaddress As String
ReDim arr(0, 0)
For Each sh In Sheets
 If sh.Name <> "Match %" Then
   sv = sh.Cells(1).CurrentRegion
 For i = 1 To UBound(sv)
  If LCase(sv(i, 1)) = "lost " And sv(i, 2) <> "" Then
   Set c = sh.Columns(2).Find(sv(i, 2), , xlValues, xlPart)
    If Not c Is Nothing Then
      firstaddress = c.Address
        Do
           If c.Offset(, -1).Value = "found" And sv(i, 2) & sv(i, 3) Like c & c.Offset(, 1) Then
             arr(0, UBound(arr, 2)) = sh.Name & "; lost rij " & i & " ; found rij " & c.Row
             ReDim Preserve arr(0, UBound(arr, 2) + 1)
           End If
          Set c = sh.Columns(2).FindNext(c)
       Loop While Not c Is Nothing And c.Address <> firstaddress
     End If
    End If
  Next i
End If
Next sh
  With Sheets("match %").Cells(1)
  .CurrentRegion.ClearContents
  .Resize(UBound(arr, 2)) = Application.Transpose(arr)
 End With
End Sub