Sub Get_List()
Dim arrData As Variant
Dim arrSearch As Variant
Dim arrSort As Variant
Dim strSearch As String
Dim objdic As Object
Dim lngR As Long, lngC As Long, lngN As Long, lngS As Long
Dim lngOutput As Long
  
 lngOutput = 3 '<--Output up to the 3rd best
  
 'Get raw data
With ActiveSheet
    arrData = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
End With
  
 arrSearch = InputBox("How many columns shall be joined to look for?" & vbCrLf _
                    & "The limit is: " & UBound(arrData, 2), "Create Search-String", "2")
 
If Not IsNumeric(arrSearch) Then GoTo TheEnd
If CLng(arrSearch) > UBound(arrData, 2) Then GoTo TheEnd
If CLng(arrSearch) > 0 Then
    lngN = CLng(arrSearch) - 1
Else
    GoTo TheEnd
End If
  
 Set objdic = CreateObject("scripting.dictionary")
 
'Search and count pairs
For lngR = 1 To UBound(arrData, 1)
    For lngC = 1 To UBound(arrData, 2) - lngN
        strSearch = ""
        For lngS = 0 To lngN
            strSearch = strSearch & arrData(lngR, lngC + lngS) & ";"
        Next lngS
        If objdic.exists(strSearch) Then
            objdic(strSearch) = objdic(strSearch) + 1
        Else
            objdic(strSearch) = 1
        End If
    Next lngC
Next lngR
'No results:
If objdic.Count = 0 Then
    MsgBox "No results!"
    Set objdic = Nothing
    Exit Sub
End If
'Sorting results:
If objdic.Count > 1 Then
    'Get keys and items for sorting
    arrSearch = objdic.Keys
    arrSort = objdic.Items
    'Sort the list
        QuickSort arrSort, arrSearch
    'Get number of Data matching best of (up to lngOutput)
    lngS = 1
    For lngR = 1 To UBound(arrSort)
        If arrSort(lngR) < arrSort(lngR - 1) Then
            lngS = lngS + 1
            If lngS > lngOutput Then
                lngOutput = lngR - 1
                Exit For
            End If
        End If
    Next lngR
    If lngR > UBound(arrSort) Then
        'If lngS = 1 Then
            lngOutput = UBound(arrSort)
        'End If
    End If
End If
'Shuffle results back to an array
If lngOutput > UBound(arrSort) Then
    lngOutput = UBound(arrSort)
End If
ReDim arrData(0 To lngOutput, 0 To 1)
For lngR = 0 To lngOutput
    arrData(lngR, 0) = arrSearch(lngR)
    arrData(lngR, 1) = arrSort(lngR)
Next lngR
'Output
With Sheets("Output")
    .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
    .Cells(1, 1).Resize(UBound(arrData, 1) + 1, 2).Value = arrData
    .Activate
End With
 Set objdic = Nothing
Exit Sub
 TheEnd:
    MsgBox "InputBox wasn't filled correctly!"
    
End Sub
  
 Private Sub QuickSort(vSort As Variant, vData As Variant, _
                        Optional ByVal lngStart As Variant, _
                        Optional ByVal lngEnd As Variant)
If IsMissing(lngStart) Then lngStart = LBound(vSort)
If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
Dim i As Long
Dim j As Long
Dim h As Variant
Dim x As Double
i = lngStart: j = lngEnd
x = vSort((lngStart + lngEnd) / 2)
Do
    While (vSort(i) > x): i = i + 1: Wend
    While (vSort(j) < x): j = j - 1: Wend
    If (i <= j) Then
        h = vSort(i)
        vSort(i) = vSort(j)
        vSort(j) = h
        h = vData(i)
        vData(i) = vData(j)
        vData(j) = h
        i = i + 1: j = j - 1
    End If
Loop Until (i > j)
If (lngStart < j) Then QuickSort vSort, vData, lngStart, j
If (i < lngEnd) Then QuickSort vSort, vData, i, lngEnd
End Sub