Sub io()
       Dim rst
       Dim sql As String
       Dim connString As String
       Dim prev As String
       Dim curr As String
       Dim collect As String
       Dim arr()
       Dim i
          
       Set rst = CreateObject("ADODB.Recordset")
       connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                    & ThisWorkbook.FullName & _
                    ";Extended Properties='Excel 12.0;HDR=No'"

       'находим все возможные четверки чисел
       sql = ""
       sql = sql & "SELECT F1, F2 FROM ( "
       sql = sql & "SELECT F1, Trim(Mid(F1, 1,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 2,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 3,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 4,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 5,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 6,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 7,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 8,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1, 9,4)) AS F2 FROM [Лист1$] UNION ALL "
       sql = sql & "SELECT F1, Trim(Mid(F1,10,4)) AS F2 FROM [Лист1$] "
       sql = sql & ") WHERE F2 Like '[0-9][0-9][0-9][0-9]' "
       sql = sql & "ORDER BY F2 "
          
       rst.Open sql, connString
       [Лист2].Cells.ClearContents
       [Лист2!A1].CopyFromRecordset rst
       rst.Close
       Call saveThisWorkbook
          
       'находим уникальные четверки, встречающиеся более одного раза
       sql = "SELECT F2 FROM [Лист2$] GROUP BY F2 HAVING Count(*) > 1"
          
       rst.Open sql, connString
       [Лист3].Cells.ClearContents
       [Лист3!A1].CopyFromRecordset rst
       rst.Close
          
       'нумеруем уникальные четверки
       With [Лист3!A1].CurrentRegion.Offset(0, 1)
           .Formula = "=ROW()"
           .Value = .Value
       End With
       Call saveThisWorkbook
          
       'привязываем номера уникальных четверок к записям Лист2
       sql = ""
       sql = sql & "SELECT L.F1, L.F2, R.F2 FROM [Лист2$] AS L LEFT JOIN [Лист3$] AS R "
       sql = sql & "ON L.F2 = R.F1 WHERE R.F1 Is Not Null ORDER BY 1, 3"
          
       rst.Open sql, connString
       [Лист4].Cells.ClearContents
       [Лист4!A1].CopyFromRecordset rst
       rst.Close
       Call saveThisWorkbook
          
       'прописываем номера четверок через запятую
       rst.Open sql, connString
          
       ReDim arr(1 To [Лист4!A1].CurrentRegion.Rows.Count, 1 To 2)
          
       prev = ""
       collect = ""
       i = 0
          
       Do While Not rst.EOF
           curr = rst(0)
           If curr <> prev Then
               'прерываем цепочку и записываем в массив
               If collect <> "" Then
                   i = i + 1
                   arr(i, 1) = prev
                   arr(i, 2) = Left(collect, Len(collect) - 1)
               End If
               'начинаем новую цепочку
               collect = rst(2) & ","
           Else
               'продолжаем цепочку
               collect = collect & rst(2) & ","
           End If
           prev = curr
           rst.MoveNext
       Loop
       'заключительная цепочка
       If collect <> "" Then
           i = i + 1
           arr(i, 1) = prev
           arr(i, 2) = Left(collect, Len(collect) - 1)
       End If
          
       rst.Close
          
       'выгружаем массив на Лист5
       [Лист5!A1].Resize(i, 2) = arr
       Call saveThisWorkbook
          
End Sub

Sub saveThisWorkbook()
       Application.DisplayAlerts = False
       ThisWorkbook.Save
       Application.DisplayAlerts = True
End Sub

Option Explicit

Public Function GetMyText(txt, Optional pattern As String = "[A-Za-zА-Яа-яЁё]") As String
     Dim M As String, i As Long, S
     For i = 1 To Len(txt)
         M = Mid(txt, i, 1)
         If M Like pattern Then S = S & M
     Next i
     GetMyText = S
End Function

Private Sub CommandButton1_Click()
Dim M(), LR, R, i, j, T, K, L, C, ii
Dim D: Set D = CreateObject("Scripting.Dictionary")
Range("B1:J500").ClearContents

LR = Cells(Rows.Count, 1).End(xlUp).Row
M = Range("A1").Resize(LR, 2)
For R = 1 To LR
     M(R, 2) = ""
Next R
For R = 1 To LR
         T = GetMyText(M(R, 1), "[0-9]")
         If Len(T) > 4 Then
             For i = 1 To Len(T) - 3
                 j = "'" & Mid(T, i, 4)
                 D(j) = D(j) + 1
             Next i
         End If
Next R
For Each C In D.keys
     If D(C) < 2 Then D.Remove C
Next C
i = 0
For Each C In D.keys
     i = i + 1
     D(C) = i
Next C
Range("F1").Resize(D.Count) = Application.Transpose(D.items)
Range("G1").Resize(D.Count) = Application.Transpose(D.keys)
For R = 1 To LR
     For Each C In D.keys
         If InStr(1, M(R, 1), Replace(C, "'", "")) Then
              M(R, 2) = IIf(M(R, 2) = "", D(C), M(R, 2) & "," & D(C))
         End If
      Next C
Next R
Range("A1").Resize(LR, 2) = M
End Sub