VB:

Const v As Single = 0.001
Private Sub Julia1()
Dim a, i As Long, j As Long, c As Long, k As Long, l As Long
Dim m As Long, dic As Object, w(), t(), Flg As Boolean, n As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
n = .Cells(4, Columns.Count).End(xlToLeft).Column
a = .Range(.Cells(4, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, n))
End With
l = (UBound(a, 2) / 8) + 1: k = 2
Redim w(1 To UBound(a, 1) * l, 1 To l)
For c = 6 To UBound(a, 2) Step 8
For i = 1 To UBound(a, 1)
If Not IsEmpty(a(i, c)) And a(i, c) <> 0 Then
If Not dic.exists(a(i, c)) Then
j = j + 1: w(j, 1) = a(i, c): w(j, k) = a(i, c - 1)
dic.Add a(i, c), w
End If
End If
Next
k = k + 1
Next
Set dic = Nothing: Erase a
On Error Resume Next
Application.DisplayAlerts = 0
Sheets("Results").Delete
Application.DisplayAlerts = 1
With Sheets.Add
.Name = "Results"
.Cells(1, 1) = "MSA"
For i = 1 To l - 1
.Cells(1, i + 1) = "SS" & i
Next
.Cells(2, 1).Resize(j, l).Value = w
With .Cells(2, 1).Resize(j + 1, l + 1)
.Sort .Range("a2"), xlAscending
.Cells(1, l + 1).Formula = "=A2"
.Cells(2, l + 1).Resize(j, 1).Formula = "=IF((RC[" & -l & "]-R[-1]C)>" & v & ",RC[" & -l & "],0)"
a = .Value
End With
Redim t(1 To UBound(a, 1), 1 To l): j = 0: k = 0
For i = 1 To UBound(a, 1)
If a(i, l + 1) <> 0 Then
j = j + 1: For c = 1 To l: t(j, c) = a(i, c): Next
Else
For m = 2 To l
If Not IsEmpty(a(i, m)) And Not IsEmpty(a(i - 1, m)) Then
Flg = True: Exit For
End If
Next
If Flg Then
j = j + 1: For c = 1 To l: t(j, c) = a(i, c): Next
Else
For c = 1 To l
If IsEmpty(t(j, c)) Then t(j, c) = a(i, c)
Next
End If
Flg = False
End If
Next
.Range(.Cells(2, 1), .Cells(2, 1).SpecialCells(xlCellTypeLastCell)).ClearContents
.Cells(2, 1).Resize(j, l) = t
End With
End Sub
Private Sub Julia2()
Dim ws As Worksheet, Rng As Range, l As Long, r As Long
Dim a, t(), j As Long, i As Long, c As Long, m As Long
Set ws = Sheets("Results")
l = ws.Cells(1, Columns.Count).End(xlToLeft).Column
r = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(r, l + 1))
With Rng
.Cells(2, l + 1).Formula = "=A2"
.Cells(3, l + 1).Resize(r, 1).Formula = "=IF(RC[" & -l & "]-R[-1]C>" & v & ",RC[" & -l & "],0)"
a = .Value
Redim t(1 To UBound(a, 1), 1 To l)
For i = 2 To UBound(a, 1)
If a(i, l + 1) <> 0 Then
j = j + 1: For c = 1 To l: t(j, c) = a(i, c): Next
Else
For m = 2 To l
If Not IsEmpty(a(i, m)) And Not IsEmpty(a(i - 1, m)) Then
Flg = True: Exit For
End If
Next
If Flg Then
j = j + 1: For c = 1 To l: t(j, c) = a(i, c): Next
Else
For c = 1 To l
If IsEmpty(t(j, c)) Then t(j, c) = a(i, c)
Next
End If
Flg = False
End If
Next
.Range(.Cells(2, 1), .Cells(2, 1).SpecialCells(xlCellTypeLastCell)).ClearContents
.Cells(2, 1).Resize(j, l) = t
End With
End Sub
Sub Main()
Call Julia1
Call Julia2
End Sub

HTH
## Bookmarks