Ricerca dentro le righe

Option Explicit

Sub Analizza()
Application.ScreenUpdating = False
Dim Rcr As Byte, x As Byte, y As Byte, z As Byte, k As Byte
Dim Vlr1 As Byte, Vlr2 As Byte
Dim Cnt() As Byte
Dim Mbb As Long
Const Rgg As Byte = 18
Const Cln As Byte = 8
    
    With Worksheets("Foglio2")
    .Select
        Mbb = .Range("B" & .Rows.Count).End(xlUp).Row
            Range(Cells(2, 1), Cells(Mbb, 1)).ClearContents
ReDim Cnt(Mbb + 10)
    Sheets("Foglio1").Select
        For x = 2 To Mbb
            Vlr1 = .Cells(x, 2)
            Vlr2 = .Cells(x, 3)
            For y = 1 To Rgg
                For z = 1 To Cln
                    If Cells(y, z) = Vlr1 Then
                        For k = 1 To Cln
                            If Cells(y, k) = Vlr2 Then
                                Cnt(x - 1) = Cnt(x - 1) + 1
                                    Exit For
                            End If
                        Next k
                    End If
                Next z
            Next y
        Next x
    .Select
        For x = 2 To Mbb
            Cells(x, 1) = Cnt(x - 1)
        Next x
    End With
Application.ScreenUpdating = True
End Sub

Option Explicit

Sub Analizza_Tutti()
Application.ScreenUpdating = False
Dim Mbb As Long, ClnX As Long, x As Long, Prv As Long
Dim Nrg As Byte, NrX As Byte, Rsl As Byte, y As Byte, z As Byte, k As Byte, PCl As Byte
Dim Vlr() As Byte
Dim ROk()
Dim Cnt()
Const Rgh As Long = 26
Const Cln As Long = 12

ReDim Vlr(Rgh)
ReDim ROk(Rgh, 1)

    Sheets("Foglio1").Select
    With Worksheets("Foglio2")
    .Select
        Mbb = .Range("C" & .Rows.Count).End(xlUp).Row
            Range(Cells(1, 1), Cells(Mbb, 2)).ClearContents
ReDim Cnt(Mbb + 1, 2)
    Sheets("Foglio1").Select
        For x = 1 To Mbb
            ClnX = .Cells(x, Columns.Count).End(xlToLeft).Column
                Rsl = 0
            Nrg = 0
            PCl = 3
            Cnt(x, 2) = ""
                Vlr(1) = .Cells(x, PCl)
                For y = 1 To Rgh
                    Cells(y, 1).Select
                    For z = 1 To Cln
                        Cells(y, z).Select
                            If Cells(y, z) = Vlr(1) Then
                                Nrg = Nrg + 1
                                ROk(Nrg, 1) = y
                                Exit For
                            End If
                    Next z
                Next y
                NrX = Nrg
                Nrg = 0
                PCl = PCl + 1
    For Prv = 2 To ClnX - 1
        Cnt(x, 2) = ""
                    Vlr(Prv) = .Cells(x, Prv + 1)
                For y = 1 To NrX
                    For z = 1 To Cln
                        Cells(ROk(y, 1), z).Select
                                If Cells(ROk(y, 1), z) = Vlr(Prv) Then
                                    Nrg = Nrg + 1
                                    k = ActiveCell.Row
                                    ROk(Nrg, 1) = k
                                        Cnt(x, 2) = Cnt(x, 2) & k & ", "
                                            Exit For
                                End If
                            NrX = Nrg
                        Next z
                    Next y
                        NrX = Nrg
                        Nrg = 0
                Next Prv
                        Cnt(x, 1) = NrX
            If Cnt(x, 1) <> 0 Then
                .Cells(x, 1) = Cnt(x, 1)
                .Cells(x, 2) = "Righe: " & Left(Cnt(x, 2), Len(Cnt(x, 2)) - 2)
            End If
        Next x
    Cells(1, 1).Select
Fine:
    .Select
            Columns("A:B").EntireColumn.AutoFit
    End With
Application.ScreenUpdating = True
    Cells(1, 1).Select
End Sub