Esecuzione codice-Pausa....

Sub Analizza2()
Dim oDic As Object
Set oDic = CreateObject("scripting.dictionary")
Set wk = Worksheets("fascia")
cells.clearcontents
With oDic
    For c = 1 To 21 Step 5
        ur = wk.Cells(Rows.Count, c).End(xlUp).Row
        For r = 2 To ur
            For c1 = c To c + 3
                If wk.Cells(r, c1) <> "" Then mcomb = mcomb & wk.Cells(r, c1) & " "
            Next c1
            If mcomb <> "" Then
                mcomb = Left(mcomb, Len(mcomb) - 1)
                If Not .exists(mcomb) Then
                    .Add mcomb, 1
                Else
                    oDic(mcomb) = oDic(mcomb) + 1
                End If
                mcomb = ""
            End If
        Next r
    Next c
End With
arrK = oDic.keys
arrK1 = oDic.items
riga = 1
c = 1
For j = 0 To UBound(arrK)
    test = Split(arrK(j), " ")
    For I = 0 To UBound(test)
        Cells(riga, c) = test(I)
        c = c + 1
    Next
    c = 1
    riga = riga + 1
Next
[E1].Resize(UBound(arrK1) + 1) = Application.Transpose(arrK1)
End Sub

Sub Analizza2()
Dim oDic As Object
t = Time
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set oDic = CreateObject("scripting.dictionary")
Set wk = Worksheets("fascia")
Worksheets("contatore-finale").Select
Cells.ClearContents
With oDic
    For c = 1 To 21 Step 5
        ur = wk.Cells(Rows.Count, c).End(xlUp).Row
        For r = 2 To ur
            For c1 = c To c + 3
                If wk.Cells(r, c1) <> "" Then mcomb = mcomb & wk.Cells(r, c1) & " "
            Next c1
            If mcomb <> "" Then
                mcomb = Left(mcomb, Len(mcomb) - 1)
                If Not .exists(mcomb) Then
                    .Add mcomb, 1
                Else
                    oDic(mcomb) = oDic(mcomb) + 1
                End If
                mcomb = ""
            End If
        Next r
    Next c
End With
If oDic.Count > 1040000 Then
    MsgBox "Troppe righe, foglio non capiente"
    Exit Sub
End If
Arrk = oDic.keys
arrk1 = oDic.items
For j = 0 To UBound(Arrk)
    Cells(j + 1, 1) = Arrk(j)
    Cells(j + 1, 6) = arrk1(j)
Next
'[E1].Resize(UBound(arrk1) + 1) = Application.Transpose(arrk1)

Range("A1:A" & UBound(Arrk) + 1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
        True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationManual
MsgBox Format(Time - t, "hh:mm:ss")

End Sub

Sub Analizza()
Dim oDic As Object
Dim arrOut() As Variant, arrSplit As Variant
t = Time
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set oDic = CreateObject("scripting.dictionary")
Set wk = Worksheets("fascia")
Worksheets("contatore-finale").Select
Cells.ClearContents
With oDic
    For c = 1 To 25 Step 6
        ur = wk.Cells(Rows.Count, c).End(xlUp).Row
        For r = 2 To ur
            For c1 = c To c + 4
                If wk.Cells(r, c1) <> "" Then mcomb = mcomb & wk.Cells(r, c1) & " "
            Next c1
            If mcomb <> "" Then
                mcomb = Left(mcomb, Len(mcomb) - 1)
                If Not .exists(mcomb) Then
                    .Add mcomb, 1
                Else
                    oDic(mcomb) = oDic(mcomb) + 1
                End If
                mcomb = ""
            End If
        Next r
    Next c
End With
If oDic.Count > 1040000 Then
    MsgBox "Troppe righe, foglio non capiente"
    Exit Sub
End If
arrK = oDic.keys
arrK1 = oDic.items

ReDim arrOut(1 To oDic.Count, 1 To 5)
For I = LBound(arrK) To UBound(arrK)
    arrSplit = Split(arrK(I))
    For j = LBound(arrSplit) To UBound(arrSplit)
        arrOut(I + 1, j + 1) = arrSplit(j)
    Next j
    j = 0
Next I
    Range("A1").Resize(oDic.Count, 5).Value = arrOut

ReDim arrOut(1 To oDic.Count, 1 To 1)
For I = LBound(arrK1) To UBound(arrK1)
    arrSplit = Split(arrK1(I))
    For j = LBound(arrSplit) To UBound(arrSplit)
        arrOut(I + 1, j + 1) = arrSplit(j)
    Next j
    j = 0
Next I
Range("F1").Resize(oDic.Count, 1).Value = arrOut

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox Format(Time - t, "hh:mm:ss")

End Sub