Contatore per 5 Liste

Option Explicit

Sub Rimuovi()
    ActiveSheet.Range(Cells(1, 1), Cells(NRc, 4)).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo
End Sub

Option Explicit
Option Base 1
Public NRc As Long

Sub Analizza()
Application.ScreenUpdating = False
Dim NCl As Long, NRX As Long
Dim x As Integer
Dim y As Byte, w As Byte, z As Byte
Dim Qtr As String
Dim Cmb() As String
Dim Frq() As Byte

    Sheets("contatore-finale").Select
        NRc = Range("A" & Rows.Count).End(xlUp).Row
            Range(Cells(1, 1), Cells(NRc, 4)).ClearContents
            Range(Cells(1, 5), Cells(NRc, 5)).ClearContents
        NRc = Range("J" & Rows.Count).End(xlUp).Row
            Range(Cells(1, 10), Cells(NRc, 13)).Clear
        Columns("A:E").Interior.Pattern = xlNone
With Worksheets("fascia")
        NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
    NRX = .Range("A" & Rows.Count).End(xlUp).Row
        Range(.Cells(2, 1), .Cells(NRX, 4)).Copy Cells(NRc, 10)        
        NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
    NRX = .Range("F" & Rows.Count).End(xlUp).Row
        Range(.Cells(2, 6), .Cells(NRX, 9)).Copy Cells(NRc, 10)    
        NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
    NRX = .Range("K" & Rows.Count).End(xlUp).Row
        Range(.Cells(2, 11), .Cells(NRX, 14)).Copy Cells(NRc, 10)        
        NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
    NRX = .Range("P" & Rows.Count).End(xlUp).Row
        Range(.Cells(2, 16), .Cells(NRX, 19)).Copy Cells(NRc, 10)        
        NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
    NRX = .Range("U" & Rows.Count).End(xlUp).Row
        Range(.Cells(2, 21), .Cells(NRX, 24)).Copy Cells(NRc, 10)        
        NRc = Range("J" & Rows.Count).End(xlUp).Row
    For x = NRc To 1 Step -1
        If Cells(x, 10).Value = "" Then Cells(x, 10).EntireRow.Delete
    Next x
        NRc = Range("J" & Rows.Count).End(xlUp).Row
    Range(Cells(1, 10), Cells(NRc, 13)).Copy Cells(1, 1)
        Range(Cells(1, 10), Cells(NRc, 13)).Clear        
			Call Rimuovi
        NRc = Range("A" & Rows.Count).End(xlUp).Row
            Range(Cells(1, 5), Cells(50, 5)).ClearContents
ReDim Cmb(NRc)
ReDim Frq(NRc)
    For x = 1 To NRc
        For y = 1 To 4
            NCl = Cells(x, Columns.Count).End(xlToLeft).Column
                If Cells(x, y).Value = "" Then Exit For
                Cmb(x) = Cmb(x) & Cells(x, y).Value & "-"
        Next y
            Cmb(x) = Left(Cmb(x), Len(Cmb(x)) - 1)
    Next x
    
        For x = 1 To 21 Step 5  '   Colonne
                NRX = .Cells(Rows.Count, x).End(xlUp).Row
            For y = 2 To NRX    '   Righe
                        Qtr = ""
                        For w = 0 To 3
                            If .Cells(y, x + w).Value <> "" Then Qtr = Qtr & .Cells(y, x + w).Value & "-"
                        Next w
                            If Qtr <> "" Then Qtr = Left(Qtr, Len(Qtr) - 1)
                        For z = 1 To NRc
                            If Qtr = Cmb(z) Then
                                Frq(z) = Frq(z) + 1
                                        Cells(z, 5) = Frq(z)
                            End If
                        Next z
            Next y
        Next x
End With
Application.ScreenUpdating = True
    Cells(1, 5).Select
End Sub